home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-1.LHA / CLISP960530-sr.lha / src / pathname.d < prev    next >
Encoding:
Text File  |  1996-08-01  |  444.8 KB  |  10,197 lines
  1. # Pathnames für CLISP
  2. # Bruno Haible 23.6.1995
  3. # Logical Pathnames: Marcus Daniels 16.9.1994
  4.  
  5. #include "lispbibl.c"
  6.  
  7. #ifdef HAVE_DISASSEMBLER
  8.   #include <string.h> # declares strlen()
  9.   #ifdef RETSTRLENTYPE # unless strlen() is a macro
  10.     extern RETSTRLENTYPE strlen (STRLEN_CONST char* s);
  11.   #endif
  12. #endif
  13.  
  14. #if defined(UNIX) || defined(WIN32_UNIX)
  15.   # Library-Funktion realpath implementieren:
  16.   # [Copyright: SUN Microsystems, B. Haible]
  17.   # TITLE
  18.   #   REALPATH(3)
  19.   # SYNOPSIS
  20.   #   char* realpath (const char* path, char resolved_path[MAXPATHLEN]);
  21.   # DESCRIPTION
  22.   #   realpath() expands all symbolic links  and  resolves  refer-
  23.   #   ences  to '/./', '/../' and extra '/' characters in the null
  24.   #   terminated string named by path and stores the canonicalized
  25.   #   absolute pathname in the buffer named by resolved_path.  The
  26.   #   resulting path will have no symbolic links  components,  nor
  27.   #   any '/./' or '/../' components.
  28.   # RETURN VALUES
  29.   #   realpath() returns a pointer to the  resolved_path  on  suc-
  30.   #   cess.   On  failure, it returns NULL, sets errno to indicate
  31.   #   the error, and places in resolved_path the absolute pathname
  32.   #   of the path component which could not be resolved.
  33.   #define realpath  my_realpath  # Consensys deklariert realpath() bereits...
  34.   local char* realpath (const char* path, char* resolved_path);
  35.   # Methode: benutze getwd und readlink.
  36.   local char* realpath(path,resolved_path)
  37.     const char* path;
  38.     char* resolved_path;
  39.     { char mypath[MAXPATHLEN];
  40.       int symlinkcount = 0; # Anzahl bisher aufgetretener symbolischer Links
  41.       char* resolved_limit = &resolved_path[MAXPATHLEN-1];
  42.       # Gültige Pointer sind die mit resolved_path <= ptr <= resolved_limit.
  43.       # In *resolved_limit darf höchstens noch ein Nullbyte stehen.
  44.       # (Analog mit mypath.)
  45.       char* resolve_start;
  46.       { char* resolved_ptr = resolved_path; # (bleibt stets <= resolved_limit)
  47.         # evtl. Working-Directory benutzen:
  48.         if (!(path[0]=='/')) # kein absoluter Pathname ?
  49.           { if (getwd(resolved_path) == NULL) { return NULL; }
  50.             resolved_ptr = resolved_path;
  51.             while (*resolved_ptr) { resolved_ptr++; }
  52.             if (resolved_ptr < resolved_limit) { *resolved_ptr++ = '/'; }
  53.             resolve_start = resolved_ptr;
  54.           }
  55.           else
  56.           { resolve_start = resolved_ptr = &resolved_path[0]; }
  57.         # Dann path selber einkopieren:
  58.        {const char* path_ptr = path;
  59.         while ((resolved_ptr < resolved_limit) && *path_ptr)
  60.           { *resolved_ptr++ = *path_ptr++; }
  61.         # Mit '/' und einem Nullbyte abschließen:
  62.         if (resolved_ptr < resolved_limit) { *resolved_ptr++ = '/'; }
  63.         *resolved_ptr = 0;
  64.       }}
  65.       # Los geht's nun in resolved_path ab resolve_start.
  66.       { char* from_ptr = resolve_start;
  67.         char* to_ptr = resolve_start;
  68.         while ((to_ptr < resolved_limit) && (*from_ptr))
  69.           # Bis hierher hat der Pfad in  resolved_path[0]...to_ptr[-1]
  70.           # die Gestalt '/subdir1/subdir2/.../txt',
  71.           # wobei 'txt' evtl. leer, aber kein subdir leer.
  72.           { char next = *from_ptr++; *to_ptr++ = next;
  73.             if ((next == '/') && (to_ptr > resolved_path+1))
  74.               # to_ptr[-1]='/'  ->  Directory ...to_ptr[-2] auflösen:
  75.               { char* last_subdir_end = &to_ptr[-2];
  76.                 switch (*last_subdir_end)
  77.                   { case '/':
  78.                       # '//' wird zu '/' vereinfacht:
  79.                       to_ptr--;
  80.                       break;
  81.                     case '.':
  82.                       { char* last_subdir_ptr = &last_subdir_end[-1];
  83.                         if (to_ptr > resolved_path+2)
  84.                           { if (*last_subdir_ptr == '.')
  85.                               { if ((to_ptr > resolved_path+4) && (*--last_subdir_ptr == '/'))
  86.                                   # letztes subdir war '/../'
  87.                                   # Dafür das subdir davor entfernen:
  88.                                   { while ((last_subdir_ptr > resolved_path) && !(*--last_subdir_ptr == '/'));
  89.                                     to_ptr = last_subdir_ptr+1;
  90.                               }   }
  91.                             elif (*last_subdir_ptr == '/')
  92.                               { # letztes subdir war '/./'
  93.                                 # entfernen:
  94.                                 to_ptr = last_subdir_end;
  95.                       }   }   }
  96.                       break;
  97.                     default:
  98.                       # nach einem normalen subdir
  99.                       #ifdef HAVE_READLINK
  100.                       # symbolischen Link lesen:
  101.                       to_ptr[-1]=0; # '/' durch 0 ersetzen
  102.                       { int linklen = readlink(resolved_path,mypath,sizeof(mypath)-1);
  103.                         if (linklen >=0)
  104.                           # war ein symbolisches Link
  105.                           { if (++symlinkcount > MAXSYMLINKS) { errno = ELOOP_VALUE; return NULL; }
  106.                             # noch aufzulösenden path-Anteil an den Link-Inhalt anhängen:
  107.                             { char* mypath_ptr = &mypath[linklen]; # ab hier ist Platz
  108.                               char* mypath_limit = &mypath[MAXPATHLEN-1]; # bis hierher
  109.                               if (mypath_ptr < mypath_limit) { *mypath_ptr++ = '/'; } # erst ein '/' anhängen
  110.                               # dann den Rest:
  111.                               while ((mypath_ptr <= mypath_limit) && (*mypath_ptr = *from_ptr++)) { mypath_ptr++; }
  112.                               *mypath_ptr = 0; # und mit 0 abschließen
  113.                             }
  114.                             # Dies ersetzt bzw. ergänzt den path:
  115.                             if (mypath[0] == '/')
  116.                               # ersetzt den path:
  117.                               { from_ptr = &mypath[0]; to_ptr = resolved_path;
  118.                                 while (*to_ptr++ = *from_ptr++);
  119.                                 from_ptr = resolved_path;
  120.                               }
  121.                               else
  122.                               # ergänzt den path:
  123.                               { # Linknamen streichen. Dazu bis zum letzten '/' suchen:
  124.                                 { char* ptr = &to_ptr[-1];
  125.                                   while ((ptr > resolved_path) && !(ptr[-1] == '/')) { ptr--; }
  126.                                   from_ptr = ptr;
  127.                                 }
  128.                                 { char* mypath_ptr = &mypath[0]; to_ptr = from_ptr;
  129.                                   while ((to_ptr <= resolved_limit) && (*to_ptr++ = *mypath_ptr++));
  130.                               } }
  131.                             to_ptr = from_ptr;
  132.                           }
  133.                           else
  134.                           #if defined(UNIX_IRIX)
  135.                           if ((errno == EINVAL) || (errno == ENXIO))
  136.                           #elif defined(UNIX_MINT)
  137.                           if ((errno == EINVAL) || (errno == EACCESS))
  138.                           #else
  139.                           if (errno == EINVAL)
  140.                           #endif
  141.                             # kein symbolisches Link
  142.                             { to_ptr[-1] = '/'; } # wieder den '/' eintragen
  143.                           else
  144.                             { return NULL; } # Fehler
  145.                       }
  146.                       #endif
  147.                       break;
  148.               }   }
  149.           } # dann zum nächsten subdir
  150.         # ein '/' am Ende streichen:
  151.         if ((to_ptr[-1] == '/') && (to_ptr > resolved_path+1)) { to_ptr--; }
  152.         to_ptr[0] = 0; # durch 0 abschließen
  153.         return resolved_path; # fertig
  154.     } }
  155. #endif
  156. #ifdef RISCOS
  157.   # SYNOPSIS
  158.   #   char* realpath (char* path, char resolved_path[MAXPATHLEN]);
  159.   # RETURN VALUES
  160.   #   realpath() returns a pointer to the resolved_path on success.
  161.   #   On failure, it returns NULL and sets errno to indicate the error.
  162.   local char* realpath (char* path, char* resolved_path);
  163.   #include <sys/os.h>
  164.   local char* realpath(path,resolved_path)
  165.     var char* path;
  166.     var char* resolved_path;
  167.     { var int handle;
  168.       var int r[10];
  169.       #if 0 # Both of these implementations should work.
  170.       if (os_fopen(0x40,path,&handle)) { return NULL; }
  171.       r[0] = 7; r[1] = handle; r[2] = (long)resolved_path; r[5] = MAXPATHLEN;
  172.       os_swi(9,r);
  173.       os_fclose(handle);
  174.       #else
  175.       var os_error* err;
  176.       r[0] = 37; r[1] = (long)path; r[2] = (long)resolved_path;
  177.       r[3] = 0; r[4] = 0; r[5] = MAXPATHLEN;
  178.       err = os_swi(0x29,r);
  179.       if (err) { __seterr(err); return NULL; }
  180.       #endif
  181.       if (r[5] <= 0)
  182.         { errno = ENOMEM /* ENAMETOOLONG would be better, but does not yet exist */;
  183.           return NULL;
  184.         }
  185.       return resolved_path;
  186.     }
  187. #endif
  188.  
  189.  
  190. # ==============================================================================
  191. #                         P A T H N A M E S
  192.  
  193. #ifdef PATHNAME_MSDOS
  194. # Komponenten:
  195. # HOST          stets NIL
  196. # DEVICE        NIL oder :WILD oder "A"|...|"Z"
  197. # DIRECTORY     (Startpoint . Subdirs) wobei
  198. #                Startpoint = :RELATIVE | :ABSOLUTE
  199. #                Subdirs = () | (subdir . Subdirs)
  200. #                subdir = :CURRENT (bedeutet ".") oder
  201. #                subdir = :PARENT (bedeutet "..") oder
  202. #                subdir = :WILD-INFERIORS (bedeutet "...", alle Subdirectories) oder
  203. #                subdir = (name . type)
  204. #                 name = :WILD oder Simple-String mit max. 8 Zeichen
  205. #                 type = :WILD oder Simple-String mit max. 3 Zeichen
  206. # NAME          NIL oder :WILD oder Simple-String mit max. 8 Zeichen
  207. # TYPE          NIL oder :WILD oder Simple-String mit max. 3 Zeichen
  208. # VERSION       stets NIL (auch :WILD oder :NEWEST bei Eingabe)
  209. # Wenn ein Pathname vollständig spezifiziert sein muß (keine Wildcards),
  210. # ist :WILD, :WILD-INFERIORS nicht erlaubt, bei NAME evtl. auch nicht NIL.
  211. # Externe Notation:       A:\sub1.typ\sub2.typ\name.typ
  212. # mit Defaults:             \sub1.typ\sub2.typ\name.typ
  213. # oder                                         name.typ
  214. # oder                    *:\sub1.typ\*.*\name.*
  215. # oder Ähnliches.
  216. # Statt '\' ist - wie unter DOS üblich - auch '/' erlaubt.
  217. #endif
  218.  
  219. #ifdef PATHNAME_AMIGAOS
  220. # Komponenten:
  221. # HOST          stets NIL
  222. # DEVICE        NIL oder Simple-String
  223. # DIRECTORY     (Startpoint . Subdirs) wobei
  224. #                Startpoint = :RELATIVE | :ABSOLUTE
  225. #                Subdirs = () | (subdir . Subdirs)
  226. #                subdir = :WILD-INFERIORS (bedeutet "**" oder "...", alle Subdirectories) oder
  227. #                subdir = :PARENT (bedeutet "/" statt "subdir/") oder
  228. #                subdir = Simple-String, evtl. mit Wildcard-Zeichen ? und *
  229. # NAME          NIL oder
  230. #               Simple-String, evtl. mit Wildcard-Zeichen ? und *
  231. #               (auch :WILD bei der Eingabe)
  232. # TYPE          NIL oder
  233. #               Simple-String, evtl. mit Wildcard-Zeichen ? und *
  234. #               (auch :WILD bei der Eingabe)
  235. # VERSION       stets NIL (auch :WILD oder :NEWEST bei Eingabe)
  236. # Constraint: Startpoint = :RELATIVE nur, falls Device = NIL;
  237. #             bei angegebenem Device gibt es also nur absolute Pathnames!
  238. # Ein AMIGAOS-Filename wird folgendermaßen in Name und Typ aufgespalten:
  239. #   falls kein '.' im Filename: Name = alles, Typ = NIL,
  240. #   falls '.' im Filename: Name = alles vor, Typ = alles nach dem letzten '.' .
  241. # Groß-/Klein-Schreibung innerhalb der Strings wird bei Vergleichen ignoriert,
  242. # aber ansonsten findet keine Groß/Klein-Umwandlung statt.
  243. # Wenn ein Pathname vollständig spezifiziert sein muß (keine Wildcards),
  244. # ist :WILD, :WILD-INFERIORS nicht erlaubt, keine Wildcard-Zeichen in den
  245. # Strings, bei NAME evtl. auch nicht NIL.
  246. # Externe Notation:  device:sub1.typ/sub2.typ/name.typ
  247. # mit Defaults:             sub1.typ/sub2.typ/name.typ
  248. # oder                                        name.typ
  249. # oder                      sub1.typ/ ** /sub3.typ/x*.lsp  (ohne Spaces!)
  250. # oder Ähnliches.
  251. # Formal:
  252. #   ch ::= beliebgiges Character außer ':','/' und '*','?'
  253. #   name ::= {ch}+
  254. #   device ::= [ <leer> | ':' | name ':' ]
  255. #              ; leer = aktuelles Device, relativ ab aktuellem Directory
  256. #              ; ':'  = aktuelles Device, absolut (ab root bei Disks)
  257. #              ; name ':' = angegebenes Device, absolut (ab root bei Disks)
  258. #   subdir ::= [ <leer> | name ]                ; leer = '..'
  259. #   pathname ::= device { subdir '/' }* name
  260. # Beispiele:
  261. #   String        Device    Directory                unser Pathname
  262. #   ------        ------    ---------                --------------
  263. #   'c:foo'       'C',     device->foo               "c" (:ABSOLUTE "foo")
  264. #   'c:foo/'      'C',     device->foo               "c" (:ABSOLUTE "foo")
  265. #   'c:foo/bar'   'C',     device->foo->bar          "c" (:ABSOLUTE "foo" "bar")
  266. #   'c:/foo'      'C',     device->up->foo           "c" (:ABSOLUTE :PARENT "foo")
  267. #   'c:'          'C',     device                    "c" (:ABSOLUTE)
  268. #   ':foo'        current, device->root->foo         NIL (:ABSOLUTE "foo")
  269. #   'foo'         current, device->foo               NIL (:RELATIVE "foo")
  270. #   '/foo'        current, device->up->foo           NIL (:RELATIVE :PARENT "foo")
  271. #   '//foo/bar'   current, device->up->up->foo->bar  NIL (:RELATIVE :PARENT :PARENT "foo" "bar")
  272. #   ''            current, device                    NIL (:RELATIVE)
  273. # An einen Pathstring, der nichtleer ist und der nicht mit ':' oder '/'
  274. # endet, kann ein '/' angehängt werden, ohne seine Semantik zu verändern.
  275. # Dieser '/' muß angehängt werden, bevor man eine weitere nichtleere
  276. # Komponente anhängen kann.
  277. # An einen Pathstring, der leer ist oder mit ':' oder '/' endet, ein '/'
  278. # anzuhängen, bedeutet aber, zum Parent Directory aufzusteigen!
  279. # Bei uns wird jeder Pathstring, der leer ist oder mit ':' oder '/' endet,
  280. # als Directory-Pathname (mit Name=NIL und Type=NIL) interpretiert.
  281. #endif
  282.  
  283. #ifdef PATHNAME_UNIX
  284. # Komponenten:
  285. # HOST          stets NIL
  286. # DEVICE        stets NIL
  287. # DIRECTORY     (Startpoint . Subdirs) wobei
  288. #                Startpoint = :RELATIVE | :ABSOLUTE
  289. #                Subdirs = () | (subdir . Subdirs)
  290. #                subdir = :WILD-INFERIORS (bedeutet "**" oder "...", alle Subdirectories) oder
  291. #                subdir = Simple-String, evtl. mit Wildcard-Zeichen ? und *
  292. # NAME          NIL oder
  293. #               Simple-String, evtl. mit Wildcard-Zeichen ? und *
  294. #               (auch :WILD bei der Eingabe)
  295. # TYPE          NIL oder
  296. #               Simple-String, evtl. mit Wildcard-Zeichen ? und *
  297. #               (auch :WILD bei der Eingabe)
  298. # VERSION       stets NIL (auch :WILD oder :NEWEST bei Eingabe)
  299. # Ein UNIX-Filename wird folgendermaßen in Name und Typ aufgespalten:
  300. #   falls kein '.' im Filename: Name = alles, Typ = NIL,
  301. #   falls '.' im Filename: Name = alles vor, Typ = alles nach dem letzten '.' .
  302. # Wenn ein Pathname vollständig spezifiziert sein muß (keine Wildcards),
  303. # ist :WILD, :WILD-INFERIORS nicht erlaubt, keine Wildcard-Zeichen in den
  304. # Strings, bei NAME evtl. auch nicht NIL.
  305. # Externe Notation:  server:/sub1.typ/sub2.typ/name.typ
  306. # mit Defaults:             /sub1.typ/sub2.typ/name.typ
  307. # oder                                         name.typ
  308. # oder                      /sub1.typ/ ** /sub3.typ/x*.lsp  (ohne Spaces!)
  309. # oder Ähnliches.
  310. #endif
  311.  
  312. #ifdef PATHNAME_OS2
  313. # Komponenten:
  314. # HOST          stets NIL
  315. # DEVICE        NIL oder :WILD oder "A"|...|"Z"
  316. # DIRECTORY     (Startpoint . Subdirs) wobei
  317. #                Startpoint = :RELATIVE | :ABSOLUTE
  318. #                Subdirs = () | (subdir . Subdirs)
  319. #                subdir = :WILD-INFERIORS (bedeutet "**" oder "...", alle Subdirectories) oder
  320. #                subdir = Simple-String, evtl. mit Wildcard-Zeichen ? und *
  321. # NAME          NIL oder
  322. #               Simple-String, evtl. mit Wildcard-Zeichen ? und *
  323. #               (auch :WILD bei der Eingabe)
  324. # TYPE          NIL oder
  325. #               Simple-String, evtl. mit Wildcard-Zeichen ? und *
  326. #               (auch :WILD bei der Eingabe)
  327. # VERSION       stets NIL (auch :WILD oder :NEWEST bei Eingabe)
  328. # Ein OS/2-Filename wird folgendermaßen in Name und Typ aufgespalten:
  329. #   falls kein '.' im Filename: Name = alles, Typ = NIL,
  330. #   falls '.' im Filename: Name = alles vor, Typ = alles nach dem letzten '.' .
  331. # Wenn ein Pathname vollständig spezifiziert sein muß (keine Wildcards),
  332. # ist :WILD, :WILD-INFERIORS nicht erlaubt, keine Wildcard-Zeichen in den
  333. # Strings, bei NAME evtl. auch nicht NIL.
  334. # Externe Notation:       A:\sub1.typ\sub2.typ\name.typ
  335. # mit Defaults:             \sub1.typ\sub2.typ\name.typ
  336. # oder                                         name.typ
  337. # oder                    *:\sub1.typ\**\sub3.typ\x*.lsp
  338. # oder Ähnliches.
  339. # Statt '\' ist - wie unter DOS üblich - auch '/' erlaubt.
  340. #endif
  341.  
  342. #ifdef PATHNAME_RISCOS
  343. #
  344. # Peter Burwood <clisp@arcangel.demon.co.uk> writes:
  345. #
  346. # RISC OS provides several filing systems as standard (ADFS, IDEFS, NetFS,
  347. # RamFS, NetPrint) and support for extra filing systems (DOSFS, ResourceFS and
  348. # DeviceFS).
  349. #
  350. # A module called FileSwitch is at the centre of all filing system operation
  351. # in RISC OS. FileSwitch provides a common core of functions used by all
  352. # filing systems. It only provides the parts of these services that are device
  353. # independent. The device dependant services that control the hardware are
  354. # provided by separate modules, which are the actual filing systems.
  355. # FileSwitch keeps track of active filing systems and switches betwen them as
  356. # necessary.
  357. #
  358. # One of the filing system modules that RISC OS provides is FileCore. It takes
  359. # the normal calls that FileSwitch sends to a filing system module, and
  360. # converts them to a simpler set of calls to modules that control the
  361. # hardware. Unlike FileSwitch it creates a fresh instantiation of itself for
  362. # each module that it supports. Using FileCore to build filing system modules
  363. # imposes a more rigid structure on it, as more of the filing system is
  364. # predefined.
  365. #
  366. # As well as standard filing systems, FileSwitch supports image filing
  367. # systems. These provide facilities for RISC OS to handle media in foreign
  368. # formats, and to support `image files' (or partitions) in those formats.
  369. # Rather than accessing the hardware directly they rely on standard RISC OS
  370. # filing systems to do so. DOSFS is an example of an image filing system used
  371. # to handle DOS format discs.
  372. #
  373. # Terminology
  374. #
  375. # A pathname may include a filing system name, a special field, a media name
  376. # (e.g., a disc name), directory name(s), and the name of the object itself;
  377. # each of these parts of a pathname is known as an `element' of the pathname.
  378. #
  379. # Filenames
  380. #
  381. # Filename `elements' may be up to ten characters in length on FileCore-based
  382. # filing systems and on NetFS. These characters may be digits or letters.
  383. # FileSwitch makes no distinction between upper and lower case, although
  384. # filing systems can do so. As a general rule, you should not use top-bit-set
  385. # characters in filenames, although some filing systems (such as
  386. # FileCore-based ones) support them. Other characters may be used provided
  387. # they do not have a special significance. Those that do are listed below :
  388. #
  389. #    .   Separates directory specifications, e.g., $.fred
  390. #    :   Introduces a drive or disc specification, e.g., :0, :bigdisc. It also
  391. #        marks the end of a filing system name, e.g., adfs:
  392. #    *   Acts as a `wildcard' to match zero or more characters.
  393. #    #   Acts as a `wildcard' to match any single character.
  394. #    $   is the name of the root directory of the disc.
  395. #    &   is the user root directory (URD)
  396. #    @   is the currently selected directory (CSD)
  397. #    ^   is the `parent' directory
  398. #    %   is the currently selected library (CSL)
  399. #    \   is the previously selected directory (PSD)
  400. #
  401. # Directories
  402. #
  403. # The root directory, $, forms the top of the directory hierarchy
  404. # of the media which contains the CSD. $ does not have a parent directory,
  405. # trying to access its parent will just access $. Each directory name is
  406. # separated by a '.' character. For example:
  407. #
  408. #    $.Documents.Memos
  409. #    %.cc
  410. #
  411. # Filing Systems
  412. #
  413. # Files may also be accessed on filing systems other than the current one by
  414. # prefixing the filename with a filing system specification. A filing system
  415. # name may appear between '-' characters, or suffixed by a ':', though the
  416. # latter is advised since '-' can also be used to introduce a parameter on a
  417. # command line, or as part of a file name. For example:
  418. #
  419. #    -net-$.SystemMesg
  420. #    adfs:%.aasm
  421. #
  422. # Special Fields
  423. #
  424. # Special fields are used to supply more information to the filing system than
  425. # you can using standard path names; for example NetFS and NetPrint use them
  426. # to specify server addresses or names. They are introduced by a '#'
  427. # character; a variety of syntaxes are possible:
  428. #
  429. #    net#MJHardy::disc1.mike
  430. #       #MJHardy::disc1.mike
  431. #   -net#MJHardy-:disc1.mike
  432. #      -#MJHardy-:disc1.mike
  433. #
  434. # The special fields here are all MJHardy, and give the name of the fileserver
  435. # to use. Special fields may use any character except for control characters,
  436. # double quote '"', solidus '|' and space. If a special field contains a hypen
  437. # you may only use the first two syntaxes given above.
  438. #
  439. # File$Path and Run$Path
  440. #
  441. # These two special variables control exactly where a file will be looked for,
  442. # according to the operation being performed on it.
  443. #
  444. #    File$Path   for read operations
  445. #    Run$Path    for execute operations
  446. #
  447. # The contents of each variable should expand to a list or prefixes, separated
  448. # by commas. When a read operation is performed then the prefixes in File$Path
  449. # are used in the order in which they are listed. The first object that
  450. # matches is used, whether it be a file or directory. Similarly any execute
  451. # operation uses the prefixes in Run$Path. These search paths are only used
  452. # when the pathname does not contain an explicit filing system reference,
  453. # e.g., executing adfs:file will not use Run$Path.
  454. #
  455. # Other path variables
  456. #
  457. # You can set up other path variables and use them as pseudo filing systems.
  458. # For example if you typed:
  459. #
  460. #    *Set Source$Path adfs:$.src.,adfs:$.public.src.
  461. #
  462. # you could then refer to the pseudo filing system as Source: or (less
  463. # preferable) as -Source-. These path variables work in the same was as
  464. # File$Path and Run$Path.
  465. #
  466. # NOTE: Path variables are not implemented in this version of CLISP. A
  467. # workaround for this is to use "<Foo$Path>" instead of "Foo:" until they are
  468. # made available.
  469. #
  470. #
  471. # from Lisp-string notation to internal representation
  472. # ----------------------------------------------------
  473. # NO swapping. "foo.lsp" means file type "lsp" and file name "foo".
  474. # This is pseudo-BNF:
  475. #
  476. # legal character ::= any ISO latin-1 graphic character >= ' ' except
  477. #                     '.' ':' '*' '#' '$' '&' '@' '^' '%' '\' '?'
  478. #
  479. # extended legal character ::= any ISO latin-1 graphic character >= ' ' except
  480. #                              ':' '"' '|'
  481. #
  482. # legal-wild char ::= legal char | '*' | '#' | '?'
  483. #
  484. # host ::=   '-' { extended legal char except '-' }+ '-'
  485. #          | { extended legal char except '-' } { extended legal char }* ':'
  486. #          | empty
  487. #
  488. # device ::=   ':' { legal char }+ '.'
  489. #            | empty
  490. #
  491. # directory ::=   { '$' | '&' | '@' | '%' | '\' } '.' { subdirectory }*
  492. #               | { subdirectory }+
  493. #               | empty
  494. #
  495. # '$' -> :ABSOLUTE :ROOT, '&' -> :ABSOLUTE :HOME, '@' -> :ABSOLUTE :CURRENT,
  496. # '%' -> :ABSOLUTE :LIBRARY, '\' -> :ABSOLUTE :PREVIOUS, else :RELATIVE.
  497. #
  498. # subdirectory ::= { '^' | { legal-wild char }+ } '.'
  499. #                  '^' -> :PARENT
  500. #
  501. # filename ::= { { legal-wild char }+ | empty }
  502. #
  503. # filetype ::= { '.' { legal-wild char }+ | empty }
  504. #
  505. # pathname ::= host device directory filename filetype
  506. #
  507. # Examples:
  508. # String                          Hostname Device  Directory            Name         Type
  509. # -net-$.SystemMesg                "net"   NIL     (:ABSOLUTE :ROOT)    "SystemMesg" NIL
  510. # net#MJHardy::disc1.mike    "net#MJHardy" "disc1" (:ABSOLUTE :ROOT)    "mike"       NIL
  511. # #MJHardy::disc1.mike          "#MJHardy" "disc1" (:ABSOLUTE :ROOT)    "mike"       NIL
  512. # -net#MJHardy-:disc1.mike   "net#MJHardy" "disc1" (:ABSOLUTE :ROOT)    "mike"       NIL
  513. # -#MJHardy-:disc1.mike         "#MJHardy" "disc1" (:ABSOLUTE :ROOT)    "mike"       NIL
  514. # @.foo                            NIL     NIL     (:ABSOLUTE :CURRENT) "foo"        NIL
  515. # foo                              NIL     NIL     (:RELATIVE)          "foo"        NIL
  516. # ^.                               NIL     NIL     (:RELATIVE :PARENT)  NIL          NIL
  517. # @.^.                             NIL     NIL     (:ABSOLUTE :CURRENT :PARENT) NIL  NIL
  518. # foo.bar                          NIL     NIL     (:RELATIVE)          "foo"        "bar"
  519. # foo.bar.baz                      NIL     NIL     (:RELATIVE "foo")    "bar"        "baz"
  520. # foo.bar.                         NIL     NIL     (:RELATIVE "foo" "bar") NIL       NIL
  521. # foo.@.                       illegal
  522. #
  523. # from internal representation to RISCOS string
  524. # ---------------------------------------------
  525. #
  526. # with swapping _only_ of name/type components.
  527. #
  528. # Hostname    Device  Directory                   Name    Type      RISCOS String
  529. #
  530. # "net"       "disc1" (:ABSOLUTE :ROOT)           "foo"   NIL       "net::disc1.$.foo"
  531. # "net#MJ"    "disc1" (:ABSOLUTE :ROOT "foo")     "bar"   "baz"     "net#MJ::disc1.$.foo.baz.bar"
  532. # "adfs"      "4"     (:ABSOLUTE :ROOT "foo" "bar") NIL   NIL       "adfs::4.$.foo.bar"
  533. # NIL         "disc1" (:ABSOLUTE :ROOT "foo")     "bar"   NIL       ":disc1.$.foo.bar"
  534. # NIL         "disc1" (:ABSOLUTE :CURRENT)        NIL     NIL       illegal here
  535. # NIL         "disc1" (:RELATIVE)                 NIL     NIL       ":disc1."
  536. # NIL         "disc1" NIL                         NIL     NIL       ":disc1."
  537. # NIL         NIL     (:ABSOLUTE :ROOT)           "foo"   NIL       "$.foo"
  538. # NIL         NIL     (:ABSOLUTE :CURRENT)        "foo"   NIL       "@.foo"
  539. # NIL         NIL     (:RELATIVE)                 "foo"   "bar"     "bar.foo"
  540. # NIL         NIL     (:RELATIVE "foo")           "bar"   "baz"     "foo.baz.bar"
  541. # NIL         NIL     (:ABSOLUTE :LIBRARY)        "bar"   NIL       "%.bar"
  542. # NIL         NIL     (:ABSOLUTE :LIBRARY "foo")  "bar"   NIL       "%.foo.bar"
  543. # NIL         NIL     (:RELATIVE)                 "foo"   "bar"     "bar.foo"
  544. # NIL         NIL     (:RELATIVE "foo")           "bar"   NIL       "foo.bar"
  545. # NIL         NIL     (:RELATIVE "foo")           NIL     "bar"     illegal here
  546. #
  547. # That is, the RISCOS string is the flattenation-concatenation of
  548. #   (append
  549. #     (if (null hostname) "" (append hostname ":"))
  550. #     (if (null device) "" (append ":" device "."))
  551. #     (case (pop directory)
  552. #       (:ABSOLUTE (case (pop directory)
  553. #                          (:ROOT "$.")
  554. #                          (:HOME "&.")
  555. #                          (:CURRENT "@.")
  556. #                          (:LIBRARY "%.")
  557. #                          (:PREVIOUS "\\.")
  558. #       )          )
  559. #       (:RELATIVE "")
  560. #     )
  561. #     (mapcar (lambda (subdir) (append subdir ".")) directory)
  562. #     (if (null name)
  563. #       (if (null type) "" (error "type with name illegal here"))
  564. #       (if (null type)
  565. #         name
  566. #         (append type "." name)
  567. #   ) ) )
  568. #
  569. # internal representation
  570. # -----------------------
  571. #
  572. # Pathname components:
  573. # HOST          Simple-String or NIL
  574. # DEVICE        Simple-String or NIL
  575. # DIRECTORY     (Startpoint . Subdirs) where
  576. #                Startpoint = :RELATIVE | :ABSOLUTE anchor
  577. #                anchor = :ROOT | :HOME | :CURRENT | :LIBRARY | :PREVIOUS
  578. #                Subdirs = () | (subdir . Subdirs)
  579. #                subdir = :PARENT or
  580. #                subdir = simple string, may contain wildcard characters ?,# and *
  581. # NAME          NIL or
  582. #               simple string, may contain wildcard characters ?,# and *
  583. #               (may also be specified as :WILD)
  584. # TYPE          NIL or
  585. #               simple string, may contain wildcard characters ?,# and *
  586. #               (may also be specified as :WILD)
  587. # VERSION       always NIL (may also be specified as :WILD or :NEWEST)
  588. # 
  589. # Constraint: startpoint /= :ABSOLUTE :ROOT only if device = NIL. If the device
  590. # is specified, the pathname must be :ABSOLUTE :ROOT.
  591. #
  592. # Komponenten:
  593. # HOST          Simple-String oder NIL
  594. # DEVICE        Simple-String oder NIL
  595. # DIRECTORY     (Startpoint . Subdirs) wobei
  596. #                Startpoint = :RELATIVE | :ABSOLUTE Anker
  597. #                Anker = :ROOT | :HOME | :CURRENT | :LIBRARY | :PREVIOUS
  598. #                Subdirs = () | (subdir . Subdirs)
  599. #                subdir = :PARENT oder
  600. #                subdir = Simple-String, evtl. mit Wildcard-Zeichen ?,# und *
  601. # NAME          NIL oder
  602. #               Simple-String, evtl. mit Wildcard-Zeichen ?,# und *
  603. #               (auch :WILD bei der Eingabe)
  604. # TYPE          NIL oder
  605. #               Simple-String, evtl. mit Wildcard-Zeichen ?,# und *
  606. #               (auch :WILD bei der Eingabe)
  607. # VERSION       stets NIL (auch :WILD oder :NEWEST bei Eingabe)
  608. #
  609. #endif
  610.  
  611. #ifdef LOGICAL_PATHNAMES
  612. # Komponenten von Logical Pathnames:
  613. # HOST          Simple-String oder NIL
  614. # DEVICE        stets NIL
  615. # DIRECTORY     (Startpoint . Subdirs) wobei
  616. #                Startpoint = :RELATIVE | :ABSOLUTE
  617. #                Subdirs = () | (subdir . Subdirs)
  618. #               subdir = :WILD-INFERIORS (bedeutet "**", alle Subdirectories) oder
  619. #               subdir = :WILD (bedeutet "*") oder
  620. #               subdir = Simple-String, evtl. mit Wildcard-Zeichen *
  621. # NAME          NIL oder
  622. #               :WILD (bedeutet "*") oder
  623. #               Simple-String, evtl. mit Wildcard-Zeichen *
  624. # TYPE          NIL oder
  625. #               :WILD (bedeutet "*") oder
  626. #               Simple-String, evtl. mit Wildcard-Zeichen *
  627. # VERSION       NIL oder :NEWEST oder :WILD oder Integer
  628. # Externe Notation: siehe CLtl2 S. 628-629.
  629. #endif
  630.  
  631. # Wandelt Groß-/Klein-Schreibung zwischen :LOCAL und :COMMON um.
  632. # common_case(string)
  633. # > string: Simple-String oder Symbol/Zahl
  634. # < ergebnis: umgewandelter Simple-String oder dasselbe Symbol/Zahl
  635. # kann GC auslösen
  636.   local object common_case (object string);
  637. # Dasselbe, rekursiv wie mit SUBST:
  638.   local object subst_common_case (object obj);
  639. #if defined(PATHNAME_UNIX) || defined(PATHNAME_OS2) || defined(PATHNAME_RISCOS) || defined(PATHNAME_AMIGAOS)
  640.   # Betriebssystem mit Vorzug für Kleinbuchstaben oder Capitalize
  641.   local object common_case(string)
  642.     var reg6 object string;
  643.     { if (!simple_string_p(string))
  644.         return string;
  645.      {var reg7 uintL len = TheSstring(string)->length;
  646.       # Suche, ob Groß- oder Kleinbuchstaben (oder beides) vorkommen:
  647.       var reg5 boolean all_upper = TRUE;
  648.       var reg4 boolean all_lower = TRUE;
  649.       { var reg2 uintB* ptr = &TheSstring(string)->data[0];
  650.         var reg3 uintL count;
  651.         dotimesL(count,len,
  652.           { var reg1 uintB ch = *ptr++;
  653.             if (!(ch == up_case(ch))) { all_upper = FALSE; }
  654.             if (!(ch == down_case(ch))) { all_lower = FALSE; }
  655.             if (!all_upper && !all_lower) break;
  656.           });
  657.       }
  658.       if (all_upper == all_lower)
  659.         # all_upper = all_lower = TRUE: Nichts zu konvertieren.
  660.         # all_upper = all_lower = FALSE: "Mixed case represents itself."
  661.         return string;
  662.       if (all_upper)
  663.         # all_upper = TRUE, all_lower = FALSE: STRING-DOWNCASE
  664.         return string_downcase(string);
  665.         else
  666.         # all_upper = FALSE, all_lower = TRUE: STRING-UPCASE
  667.         return string_upcase(string);
  668.     }}
  669.   local object subst_common_case(obj)
  670.     var reg1 object obj;
  671.     { if (atomp(obj))
  672.         { return common_case(obj); }
  673.       check_STACK(); check_SP();
  674.       pushSTACK(obj);
  675.       # rekursiv für den CAR aufrufen:
  676.       { var reg2 object new_car = subst_common_case(Car(obj));
  677.         pushSTACK(new_car);
  678.       }
  679.       # rekursiv für den CDR aufrufen:
  680.       { var reg2 object new_cdr = subst_common_case(Cdr(STACK_1));
  681.         if (eq(new_cdr,Cdr(STACK_1)) && eq(STACK_0,Car(STACK_1)))
  682.           { obj = STACK_1; skipSTACK(2); return obj; }
  683.           else
  684.           # (CONS new_car new_cdr)
  685.           { STACK_1 = new_cdr;
  686.            {var reg1 object new_cons = allocate_cons();
  687.             Car(new_cons) = popSTACK(); Cdr(new_cons) = popSTACK();
  688.             return new_cons;
  689.     } }   }}
  690. #else # defined(PATHNAME_MSDOS)
  691.   # Betriebssystem mit Vorzug für Großbuchstaben
  692.   #define common_case(string)  string
  693.   #define subst_common_case(obj)  obj
  694. #endif
  695.  
  696. #ifdef LOGICAL_PATHNAMES
  697.  
  698. local boolean legal_logical_word_char (uintB ch);
  699. local boolean legal_logical_word_char(ch)
  700.   var reg1 uintB ch;
  701.   { ch = up_case(ch);
  702.     if (((ch >= 'A') && (ch <= 'Z'))
  703.         || ((ch >= '0') && (ch <= '9'))
  704.         || (ch == '-')
  705.        )
  706.       return TRUE;
  707.       else
  708.       return FALSE;
  709.   }
  710.  
  711. #endif
  712.  
  713. #if HAS_HOST
  714.  
  715. # UP: Stellt fest, ob ein Character als Zeichen im Host-Teil eines Namestring
  716. # erlaubt ist.
  717. # legal_hostchar(ch)
  718. # > uintB ch: Character-Code
  719. # < ergebnis: TRUE falls erlaubt, FALSE sonst
  720.   local boolean legal_hostchar (uintB ch);
  721. # NB: legal_logical_word_char(ch) impliziert legal_hostchar(ch).
  722.   local boolean legal_hostchar(ch)
  723.     var reg1 uintB ch;
  724.     {
  725.       #ifdef PATHNAME_RISCOS
  726.       return (graphic_char_p(ch) && !(ch==':') && !(ch=='"') && !(ch=='|'));
  727.       #else
  728.       return alphanumericp(ch) || (ch=='-');
  729.       #endif
  730.     }
  731.  
  732. # UP: Überprüft ein optionales Host-Argument.
  733. # test_optional_host(host,convert)
  734. # > host: Host-Argument
  735. # > convert: Flag, ob Case-Konversion erwünscht ist
  736. # > subr_self: Aufrufer (ein SUBR)
  737. # < ergebnis: gültige Host-Komponente
  738. # kann GC auslösen
  739.   local object test_optional_host (object host, boolean convert);
  740.   local object test_optional_host(host,convert)
  741.     var reg4 object host;
  742.     var reg5 boolean convert;
  743.     { if (eq(host,unbound)) { return NIL; } # nicht angegeben -> NIL
  744.       if (nullp(host)) goto OK; # NIL ist OK
  745.       # Sonst muß host ein String sein, dessen Zeichen alphanumerisch sind:
  746.       if (!stringp(host))
  747.         { pushSTACK(host); # Wert für Slot DATUM von TYPE-ERROR
  748.           pushSTACK(O(type_host)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  749.           pushSTACK(host);
  750.           pushSTACK(TheSubr(subr_self)->name);
  751.           //: DEUTSCH "~: Host muß NIL oder ein String sein, nicht ~"
  752.           //: ENGLISH "~: host should be NIL or a string, not ~"
  753.           //: FRANCAIS "~ : Le nom de machine hôte doit être NIL ou de type STRING et non ~"
  754.           fehler(type_error, GETTEXT("~: host should be NIL or a string, not ~"));
  755.         }
  756.       host = coerce_ss(host); # als Simple-String
  757.       if (convert) { host = common_case(host); }
  758.       { var reg3 uintL len = TheSstring(host)->length;
  759.         var reg2 uintB* charptr = &TheSstring(host)->data[0];
  760.         dotimesL(len,len,
  761.           { var reg1 uintB ch = *charptr++;
  762.             if (!legal_hostchar(ch)) goto badhost;
  763.           });
  764.       }
  765.       OK: return host;
  766.       badhost:
  767.         { pushSTACK(host);
  768.           pushSTACK(TheSubr(subr_self)->name);
  769.           //: DEUTSCH "~: syntaktisch illegaler Hostname ~"
  770.           //: ENGLISH "~: illegal hostname ~"
  771.           //: FRANCAIS "~ : Syntaxe incorrecte pour un nom de machine hôte: ~"
  772.           fehler(error, GETTEXT("~: illegal hostname ~"));
  773.         }
  774.     }
  775.  
  776. #else
  777.  
  778. #ifdef LOGICAL_PATHNAMES
  779.  
  780. # UP: Überprüft ein optionales Host-Argument.
  781. # test_optional_host(host)
  782. # > host: Host-Argument
  783. # > subr_self: Aufrufer (ein SUBR)
  784. # < ergebnis: gültige Host-Komponente
  785. # kann GC auslösen
  786.   local object test_optional_host (object host);
  787.   local object test_optional_host(host)
  788.     var reg4 object host;
  789.     { if (eq(host,unbound)) { return NIL; } # nicht angegeben -> NIL
  790.       if (nullp(host)) goto OK; # NIL ist OK
  791.       # Sonst muß host ein String sein, dessen Zeichen alphanumerisch sind:
  792.       if (!stringp(host))
  793.         { pushSTACK(host); # Wert für Slot DATUM von TYPE-ERROR
  794.           pushSTACK(O(type_host)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  795.           pushSTACK(host);
  796.           pushSTACK(TheSubr(subr_self)->name);
  797.           //: DEUTSCH "~: Host muß NIL oder ein String sein, nicht ~"
  798.           //: ENGLISH "~: host should be NIL or a string, not ~"
  799.           //: FRANCAIS "~ : Le nom de machine hôte doit être NIL ou de type STRING et non ~"
  800.           fehler(type_error, GETTEXT("~: host should be NIL or a string, not ~"));
  801.         }
  802.       host = coerce_ss(host); # als Simple-String
  803.       { var reg3 uintL len = TheSstring(host)->length;
  804.         var reg2 uintB* charptr = &TheSstring(host)->data[0];
  805.         dotimesL(len,len,
  806.           { var reg1 uintB ch = *charptr++;
  807.             if (!legal_logical_word_char(ch)) goto badhost;
  808.           });
  809.       }
  810.       OK: return host;
  811.       badhost:
  812.         { pushSTACK(host);
  813.           pushSTACK(TheSubr(subr_self)->name);
  814.           //: DEUTSCH "~: syntaktisch illegaler Hostname ~"
  815.           //: ENGLISH "~: illegal hostname ~"
  816.           //: FRANCAIS "~ : Syntaxe incorrecte pour un nom de machine hôte: ~"
  817.           fehler(error, GETTEXT("~: illegal hostname ~"));
  818.         }
  819.     }
  820.  
  821. #else
  822.  
  823. # UP: Überprüft ein optionales Host-Argument.
  824. # test_optional_host(host);
  825. # > host: Host-Argument
  826. # > subr_self: Aufrufer (ein SUBR)
  827. # < ergebnis: gültige Host-Komponente
  828.   local object test_optional_host (object host);
  829.   local object test_optional_host(host)
  830.     var reg1 object host;
  831.     { if (!eq(host,unbound)) # nicht angegeben -> OK
  832.         { if (!nullp(host)) # angegeben -> sollte =NIL sein
  833.             { pushSTACK(host); # Wert für Slot DATUM von TYPE-ERROR
  834.               pushSTACK(S(null)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  835.               pushSTACK(host);
  836.               pushSTACK(TheSubr(subr_self)->name);
  837.               //: DEUTSCH "~: Host muß NIL sein, nicht ~"
  838.               //: ENGLISH "~: host should be NIL, not ~"
  839.               //: FRANCAIS "~ : Le nom de machine hôte doit être NIL et non ~"
  840.               fehler(type_error, GETTEXT("~: host should be NIL, not ~"));
  841.             }
  842.         }
  843.       return NIL;
  844.     }
  845.  
  846. #endif
  847.  
  848. #endif
  849.  
  850. # Stellt fest, ob zwei Characters als Zeichen in Pathnames als gleich gelten.
  851. # equal_pathchar(ch1,ch2)
  852. # > uintB ch1,ch2: Character-Codes
  853. # < ergebnis: TRUE falls gleich, FALSE sonst
  854.   #if !(defined(PATHNAME_AMIGAOS) || defined(PATHNAME_OS2))
  855.     #define equal_pathchar(ch1,ch2)  ((ch1)==(ch2))
  856.   #else # defined(PATHNAME_AMIGAOS) || defined(PATHNAME_OS2)
  857.     # Case-insensitive, aber normalerweise ohne Konversion
  858.     #define equal_pathchar(ch1,ch2)  (up_case(ch1)==up_case(ch2))
  859.   #endif
  860.  
  861. # UP: Stellt fest, ob ein Character als Zeichen im Namens-/Typ-Teil eines
  862. # Namestring erlaubt ist.
  863. # legal_namechar(ch)
  864. # > uintB ch: Character-Code
  865. # < ergebnis: TRUE falls erlaubt, FALSE sonst
  866.   local boolean legal_namechar (uintB ch);
  867.   local boolean legal_namechar(ch)
  868.     var reg1 uintB ch;
  869.     {
  870.       #ifdef VALID_FILENAME_CHAR # defined in unixconf.h
  871.       return VALID_FILENAME_CHAR;
  872.       #else
  873.       #if defined(PATHNAME_MSDOS)
  874.       return ((ch=='_') || (ch=='-') || alphanumericp(ch));
  875.       #endif
  876.       #ifdef PATHNAME_AMIGAOS
  877.       return (graphic_char_p(ch) && !(ch=='/') && !(ch==':'));
  878.       #endif
  879.       #ifdef PATHNAME_UNIX
  880.       return ((ch>=' ') && (ch<='~') && !(ch=='/'));
  881.       #endif
  882.       #ifdef PATHNAME_OS2
  883.       return (graphic_char_p(ch) && !(ch=='\\') && !(ch=='/') && !(ch==':'));
  884.       #endif
  885.       #ifdef PATHNAME_RISCOS
  886.       return (graphic_char_p(ch) && !(ch==':') && !(ch=='.')
  887.               && !(ch=='$') && !(ch=='&') && !(ch=='@')
  888.               && !(ch=='^') && !(ch=='%') && !(ch=='\\')
  889.               # Wild Characters '*' '#' '?' sind hier erlaubt.
  890.              );
  891.       #endif
  892.       #endif
  893.     }
  894.  
  895. # Stellt fest, ob ein Character ein Wildcard-Platzhalter für ein einzelnes
  896. # Zeichen ist.
  897. # singlewild_char_p(ch)
  898. # > uintB ch: Character-Code
  899. # < ergebnis: TRUE falls ja, FALSE sonst
  900.   #if !defined(PATHNAME_RISCOS)
  901.     #define singlewild_char_p(ch)  ((ch)=='?')
  902.   #else # defined(PATHNAME_RISCOS)
  903.     #define singlewild_char_p(ch)  (((ch)=='?') || ((ch)=='#'))
  904.   #endif
  905.  
  906. # Wandelt ein Objekt in einen Pathname um.
  907.   local object coerce_xpathname (object obj); # später
  908.  
  909. # Wandelt ein Objekt in einen nicht-Logical Pathname um.
  910.   local object coerce_pathname (object obj); # später
  911. #if !defined(LOGICAL_PATHNAMES)
  912.   #define coerce_pathname(obj)  coerce_xpathname(obj)
  913. #endif
  914.  
  915. # Liefert den Default-Pathname.
  916.   local object defaults_pathname (void); # später
  917.  
  918. # Überprüft einen Default-Pathname.
  919. # test_default_pathname(defaults)
  920. # > defaults: Defaults-Argument
  921. # < ergebnis: Wert des Defaults-Arguments, ein Pathname
  922. # kann GC auslösen
  923.   local object test_default_pathname (object defaults);
  924.   local object test_default_pathname(defaults)
  925.     var reg1 object defaults;
  926.     { if (eq(defaults,unbound))
  927.         # nicht angegeben -> Wert von *DEFAULT-PATHNAME-DEFAULTS* nehmen:
  928.         { return defaults_pathname(); }
  929.         else
  930.         # angegeben -> zu einem Pathname machen:
  931.         { return coerce_xpathname(defaults); }
  932.     }
  933.  
  934. # Fehlermeldung wegen illegalem Pathname-Argument.
  935. # fehler_thing(thing);
  936. # > thing: (fehlerhaftes) Argument
  937. # > subr_self: Aufrufer (ein SUBR)
  938.   nonreturning_function(local, fehler_thing, (object thing));
  939.   local void fehler_thing(thing)
  940.     var reg1 object thing;
  941.     { pushSTACK(thing);
  942.       pushSTACK(TheSubr(subr_self)->name);
  943.       # type_error ??
  944.       //: DEUTSCH "~: Argument muß ein String, Symbol, File-Stream oder Pathname sein, nicht ~"
  945.       //: ENGLISH "~: argument should be a string, symbol, file stream or pathname, not ~"
  946.       //: FRANCAIS "~ : L'argument doit être une chaîne, un symbole, un «stream» de fichier ou un «pathname» et non ~"
  947.       fehler(error, GETTEXT("~: argument should be a string, symbol, file stream or pathname, not ~"));
  948.     }
  949.  
  950. # Verfolgt eine Kette von Synonym-Streams, solange bis bei einem File-Stream
  951. # angelangt.
  952. # as_file_stream(stream)
  953. # > stream: Stream
  954. # < stream: File-Stream
  955.   local object as_file_stream (object stream);
  956.   local object as_file_stream(stream)
  957.     var reg2 object stream;
  958.     { var reg1 object s = stream;
  959.       loop
  960.         { if_strm_file_p(s, { return s; } , ; );
  961.           if (!(TheStream(s)->strmtype == strmtype_synonym)) break;
  962.           s = Symbol_value(TheStream(stream)->strm_synonym_symbol);
  963.           if (!streamp(s)) break;
  964.         }
  965.       fehler_thing(stream);
  966.     }
  967.  
  968. #if defined(UNIX) || defined(MSDOS) || defined(RISCOS) || defined(WIN32_UNIX)
  969.  
  970. #if defined(UNIX) || defined(MSDOS) || defined(WIN32_UNIX)
  971.   #define slash  '/'
  972. #endif
  973. #ifdef RISCOS
  974.   #define slash  '.'
  975. #endif
  976.  
  977. # UP: Wandelt eine Unix-Directory-Angabe in ein Pathname um.
  978. # asciz_dir_to_pathname(path)
  979. # > const char* path: path als ASCIZ-String
  980. # < ergebnis: als Pathname ohne Name und Typ
  981.   local object asciz_dir_to_pathname (const char* path);
  982.   local object asciz_dir_to_pathname(path)
  983.     var reg4 const char* path;
  984.      { var reg1 const char* pathptr = path;
  985.        var reg2 uintL len = 0; # Stringlänge
  986.        until (*pathptr == 0) { pathptr++; len++; } # ASCIZ-Stringende suchen
  987.        # Sofern der String nicht schon mit '/' endet, wird ein '/' angefügt:
  988.        if (!((len>0) && (pathptr[-1]==slash))) { len++; }
  989.        # und in einen String umwandeln:
  990.       {var reg3 object pathname = make_string((const uintB*)path,len);
  991.        TheSstring(pathname)->data[len-1] = slash; # abschließendes '/' unterbringen
  992.        # und in ein Pathname umwandeln:
  993.        return coerce_pathname(pathname);
  994.      }}
  995.  
  996. #endif
  997.  
  998. # Typ für PARSE-NAMESTRING:
  999. # Der String wird durchlaufen.
  1000.   typedef struct { uintL index; # Index (incl. Offset)
  1001.                    object FNindex; # Index als Fixnum
  1002.                    uintL count; # Anzahl der verbleibenden Characters
  1003.                  }
  1004.           zustand;
  1005.  
  1006. #ifdef LOGICAL_PATHNAMES
  1007.  
  1008. # Parst einen Logical-Pathname.
  1009. # parse_logical_pathnamestring(z)
  1010. # > STACK_1: Datenvektor
  1011. # > STACK_0: neuer Logical Pathname
  1012. # > zustand z: Start-Zustand
  1013. # < STACK_0: selber Logical Pathname, ausgefüllt
  1014. # < ergebnis: Anzahl der übriggebliebenen Zeichen
  1015. # kann GC auslösen
  1016. local uintL parse_logical_pathnamestring (zustand z);
  1017.  
  1018. # Trennzeichen zwischen subdirs
  1019. #define slashp(c)  ((c) == ';')
  1020.  
  1021. # Parst Name/Type/Version-Teil (subdirp=FALSE) bzw. subdir-Teil (subdirp=TRUE).
  1022. # Liefert Simple-String oder :WILD oder :WILD-INFERIORS oder NIL.
  1023. local object parse_logical_word (zustand* z, boolean subdirp);
  1024. local object parse_logical_word(z,subdirp)
  1025.   var reg1 zustand* z;
  1026.   var reg7 boolean subdirp;
  1027.   { var zustand startz; startz = *z; # Start-Zustand
  1028.    {var reg4 uintB ch;
  1029.     # Kommt eine Folge von alphanumerischen Zeichen oder '*',
  1030.     # keine zwei '*' adjazent (ausgenommen "**", falls subdirp),
  1031.     # und, falls subdirp, ein ';' ?
  1032.     var reg8 boolean last_was_star = FALSE;
  1033.     var reg9 boolean seen_starstar = FALSE;
  1034.     loop
  1035.       { if (z->count == 0) break;
  1036.         ch = TheSstring(STACK_2)->data[z->index]; # nächstes Character
  1037.         if (!legal_logical_word_char(ch))
  1038.           { if (ch == '*')
  1039.               { if (last_was_star)
  1040.                   { if (subdirp && (z->index - startz.index == 1))
  1041.                       seen_starstar = TRUE;
  1042.                       else
  1043.                       break; # adjazente '*' sind verboten
  1044.                   }
  1045.                   else
  1046.                   last_was_star = TRUE;
  1047.               }
  1048.               else
  1049.               break;
  1050.           }
  1051.         # Character übergehen:
  1052.         z->index++; z->FNindex = fixnum_inc(z->FNindex,1); z->count--;
  1053.       }
  1054.    {var reg5 uintL len = z->index - startz.index;
  1055.     if (subdirp)
  1056.       { if ((z->count == 0) || !slashp(ch))
  1057.           { *z = startz; return NIL; } # kein ';' -> kein subdir
  1058.         # Character ';' übergehen:
  1059.         z->index++; z->FNindex = fixnum_inc(z->FNindex,1); z->count--;
  1060.       }
  1061.     if (len==0)
  1062.       { return NIL; }
  1063.     elif ((len==1) && (TheSstring(STACK_2)->data[startz.index]=='*'))
  1064.       { return S(Kwild); }
  1065.     elif ((len==2) && seen_starstar)
  1066.       { return S(Kwild_inferiors); }
  1067.     else # String bilden:
  1068.       { var reg6 object result = allocate_string(len);
  1069.         # und füllen:
  1070.         {var reg2 uintB* ptr1 = &TheSstring(STACK_2)->data[startz.index];
  1071.          var reg3 uintB* ptr2 = &TheSstring(result)->data[0];
  1072.          dotimespL(len,len, { *ptr2++ = up_case(*ptr1++); });
  1073.         }
  1074.         return result;
  1075.       }
  1076.    }
  1077.   }}
  1078.  
  1079. # Test auf Ziffernfolge:
  1080. local boolean all_digits (object string);
  1081. local boolean all_digits(string)
  1082.   var reg4 object string;
  1083.   { var reg2 uintB* charptr = &TheSstring(string)->data[0];
  1084.     var reg3 uintL len = TheSstring(string)->length;
  1085.     dotimesL(len,len,
  1086.       { var reg1 uintB ch = *charptr++;
  1087.         if (!((ch >= '0') && (ch <= '9'))) return FALSE;
  1088.       });
  1089.     return TRUE;
  1090.   }
  1091.  
  1092. local uintL parse_logical_pathnamestring(z)
  1093.   var zustand z;
  1094.   { # Host-Specification parsen:
  1095.     { var reg5 object host;
  1096.       var zustand startz; startz = z; # Start-Zustand
  1097.      {var reg1 uintB ch;
  1098.       # Kommt eine Folge von alphanumerischen Zeichen und dann ein ':' ?
  1099.       loop
  1100.         { if (z.count==0) goto no_hostspec; # String schon zu Ende -> kein Host
  1101.           ch = TheSstring(STACK_1)->data[z.index]; # nächstes Character
  1102.           if (!legal_logical_word_char(ch)) break;
  1103.           # alphanumerisches Character übergehen:
  1104.           z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1105.         }
  1106.       if (!(ch==':')) goto no_hostspec; # kein ':' -> kein Host
  1107.       # Host-String bilden:
  1108.       { var reg4 uintL len = z.index - startz.index;
  1109.         host = allocate_string(len);
  1110.         # und füllen:
  1111.        {var reg2 uintB* ptr1 = &TheSstring(STACK_1)->data[startz.index];
  1112.         var reg3 uintB* ptr2 = &TheSstring(host)->data[0];
  1113.         dotimesL(len,len, { *ptr2++ = up_case(*ptr1++); });
  1114.       }}
  1115.       # Character ':' übergehen:
  1116.       z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1117.       goto hostspec_ok;
  1118.      no_hostspec: # keine Host-Specification
  1119.       z = startz; # zum Start zurück
  1120.       host = STACK_(3+2); # Default-Host
  1121.      hostspec_ok:
  1122.       # Host eintragen:
  1123.       TheLogpathname(STACK_0)->pathname_host = host;
  1124.     }}
  1125.     # Directory-Start eintragen:
  1126.     { var reg1 object new_cons = allocate_cons(); # neues Cons für Startpoint
  1127.       TheLogpathname(STACK_0)->pathname_directory = new_cons;
  1128.       pushSTACK(new_cons); # neues (last (pathname-directory Pathname))
  1129.     }
  1130.     # Stackaufbau: Datenvektor, Pathname, (last (pathname-directory Pathname)).
  1131.     # Subdirectories parsen:
  1132.     # Falls sofort ein ';' kommt, wird er übergangen, und es kommt :RELATIVE
  1133.     # (sonst :ABSOLUTE) als erstes subdir:
  1134.     if ((!(z.count == 0)) && slashp(TheSstring(STACK_2)->data[z.index]))
  1135.       # Es kommt sofort ein ';'.
  1136.       { # Character übergehen:
  1137.         z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1138.         Car(STACK_0) = S(Krelative); # Startpoint = :RELATIVE
  1139.       }
  1140.       else
  1141.       # Es kommt nicht sofort ein ';'.
  1142.       { Car(STACK_0) = S(Kabsolute); } # Startpoint = :ABSOLUTE
  1143.     loop
  1144.       { # Versuche, ein weiteres Unterdirectory zu parsen.
  1145.         var reg2 object subdir = parse_logical_word(&z,TRUE);
  1146.         if (nullp(subdir)) break;
  1147.         # (pathname-directory pathname) um Subdir verlängern:
  1148.         pushSTACK(subdir);
  1149.        {var reg1 object new_cons = allocate_cons(); # neues Cons
  1150.         Car(new_cons) = popSTACK(); # = (cons subdir NIL)
  1151.         Cdr(STACK_0) = new_cons; # verlängert (pathname-directory Pathname)
  1152.         STACK_0 = new_cons; # neues (last (pathname-directory Pathname))
  1153.       }}
  1154.     # Name parsen:
  1155.     { var reg1 object name = parse_logical_word(&z,FALSE);
  1156.       TheLogpathname(STACK_1)->pathname_name = name;
  1157.       if ((z.count > 0) && (TheSstring(STACK_2)->data[z.index]=='.'))
  1158.         { var zustand z_name; z_name = z;
  1159.           # Character '.' übergehen:
  1160.           z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1161.           # Typ parsen:
  1162.          {var reg2 object type = parse_logical_word(&z,FALSE);
  1163.           TheLogpathname(STACK_1)->pathname_type = type;
  1164.           if (!nullp(type))
  1165.             { if ((z.count > 0) && (TheSstring(STACK_2)->data[z.index]=='.'))
  1166.                 { var zustand z_type; z_type = z;
  1167.                   # Character '.' übergehen:
  1168.                   z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1169.                   # Version parsen:
  1170.                  {var reg3 object version = parse_logical_word(&z,FALSE);
  1171.                   if (eq(version,S(Kwild))) { }
  1172.                   elif (equal(version,Symbol_name(S(Knewest))))
  1173.                     { version = S(Knewest); }
  1174.                   elif (all_digits(version))
  1175.                     { pushSTACK(version); funcall(L(parse_integer),1); # version in Integer umwandeln
  1176.                       version = value1;
  1177.                     }
  1178.                   else
  1179.                     { version = NIL; }
  1180.                   TheLogpathname(STACK_1)->pathname_version = version;
  1181.                   if (nullp(version))
  1182.                     { z = z_type; } # Character '.' wieder zurück
  1183.                 }}
  1184.                 else
  1185.                 { TheLogpathname(STACK_1)->pathname_version = NIL; }
  1186.             }
  1187.             else
  1188.             { z = z_name; # Character '.' wieder zurück
  1189.               TheLogpathname(STACK_1)->pathname_version = NIL;
  1190.             }
  1191.         }}
  1192.         else
  1193.         { TheLogpathname(STACK_1)->pathname_type = NIL;
  1194.           TheLogpathname(STACK_1)->pathname_version = NIL;
  1195.         }
  1196.     }
  1197.     skipSTACK(1);
  1198.     return z.count;
  1199.   }
  1200.  
  1201. #undef slashp
  1202.  
  1203. # Erkennung eines logischen Hosts, vgl. CLtL2 S. 631
  1204. # (defun logical-host-p (host)
  1205. #   (and (simple-string-p host)
  1206. #        (gethash host sys::*logical-pathname-translations*)
  1207. #        t
  1208. # ) )
  1209.   local boolean logical_host_p (object host);
  1210.   local boolean logical_host_p(host)
  1211.     var reg1 object host;
  1212.     { return (simple_string_p(host)
  1213.               # Fehlt host = string_upcase(host); ??
  1214.               && !eq(gethash(host,Symbol_value(S(logpathname_translations))),
  1215.                      nullobj
  1216.              )      );
  1217.     }
  1218.  
  1219. #endif
  1220.  
  1221. #ifdef PATHNAME_EXT83
  1222. # Hilfsfunktion für PARSE-NAMESTRING:
  1223. # Parst einen Namens- oder Typteil.
  1224. # parse_name_or_type(&z,stdlen,def)
  1225. # > stdlen: Standard-Länge des Teils
  1226. # > def: Defaultwert
  1227. # > STACK_3: Datenvektor des Strings
  1228. # > z: Zustand
  1229. # < z: Zustand
  1230. # < ergebnis: Namens- oder Typteil (=default, falls leer)
  1231. # kann GC auslösen
  1232.   local object parse_name_or_type (zustand* z, uintL stdlen, object def);
  1233.   local object parse_name_or_type(z,stdlen,def)
  1234.     var reg1 zustand* z;
  1235.     var reg5 uintL stdlen;
  1236.     var reg6 object def;
  1237.     { var reg3 uintL z_start_index = z->index; # Index beim Start des Namens
  1238.       loop
  1239.         { var reg2 uintB ch;
  1240.           if (z->count == 0) break;
  1241.           ch = TheSstring(STACK_3)->data[z->index]; # nächstes Character
  1242.           ch = up_case(ch); # als Großbuchstabe
  1243.           if (ch == '.') break;
  1244.           if (ch == '*')
  1245.             # '*' angetroffen.
  1246.             { # nicht am Anfang des Namens -> beendet den Namen:
  1247.               if (!(z->index == z_start_index)) break;
  1248.               # Character übergehen:
  1249.               z->index++; z->FNindex = fixnum_inc(z->FNindex,1); z->count--;
  1250.               return S(Kwild); # Name := :WILD
  1251.             }
  1252.           if (!legal_namechar(ch)) break; # gültiges Character ?
  1253.           # ja -> Teil des Namens
  1254.           # Character übergehen:
  1255.           z->index++; z->FNindex = fixnum_inc(z->FNindex,1); z->count--;
  1256.         }
  1257.       # Ende des Namens erreicht.
  1258.       # Name := Teilstring von STACK_3 von z_start_index (einschließlich)
  1259.       #                                bis z->index (ausschließlich).
  1260.      {var reg3 uintL len = z->index - z_start_index;
  1261.       # kein Name angegeben -> default zurück:
  1262.       if (len==0) { return def; }
  1263.       #ifndef EMUNIX_PORTABEL # unter OS/2 gilt die 8+3-Regel nicht mehr
  1264.       # bei len > stdlen setze len:=stdlen :
  1265.       if (len > stdlen) { len = stdlen; }
  1266.       #endif
  1267.       {var reg4 object string = allocate_string(len); # String der Länge len
  1268.        # füllen:
  1269.        var reg1 uintB* ptr1 = &TheSstring(STACK_3)->data[z_start_index];
  1270.        var reg2 uintB* ptr2 = &TheSstring(string)->data[0];
  1271.        dotimespL(len,len, { *ptr2++ = up_case(*ptr1++); });
  1272.        # Name fertig.
  1273.        return string;
  1274.     }}}
  1275. #endif
  1276.  
  1277. #ifdef PATHNAME_NOEXT
  1278. # Hilfsfunktion für PARSE-NAMESTRING:
  1279. # Spaltet einen String (beim letzten Punkt) in Name und Typ auf.
  1280. # split_name_type(skip);
  1281. # > STACK_0: Simple-String
  1282. # > skip: 1 falls ein Punkt an erster Stelle nicht aufspaltend wirken soll, 0 sonst
  1283. # < STACK_1: Name
  1284. # < STACK_0: Typ
  1285. # Erniedrigt STACK um 1
  1286. # kann GC auslösen
  1287.   local void split_name_type (uintL skip);
  1288.   local void split_name_type(skip)
  1289.     var reg2 uintL skip;
  1290.     { var reg5 object string = STACK_0;
  1291.       var reg7 uintL length = TheSstring(string)->length;
  1292.       # Nach dem letzten Punkt suchen:
  1293.       var reg4 uintL index = length;
  1294.       { var reg1 uintB* ptr = &TheSstring(string)->data[index];
  1295.         while (index>skip)
  1296.           { --ptr;
  1297.             if (*ptr == '.') goto punkt;
  1298.             index--;
  1299.       }   }
  1300.       # kein Punkt gefunden -> Typ := NIL
  1301.       pushSTACK(NIL);
  1302.       goto name_type_ok;
  1303.       punkt: # Punkt bei index gefunden
  1304.       { # type := (substring string index)
  1305.         var reg3 uintL count = length-index;
  1306.         var reg6 object type = allocate_string(count);
  1307.         var reg1 uintB* ptr2 = &TheSstring(type)->data[0];
  1308.         var reg2 uintB* ptr1 = &TheSstring(STACK_0)->data[index];
  1309.         dotimesL(count,count, { *ptr2++ = *ptr1++; } );
  1310.         pushSTACK(type);
  1311.       }
  1312.       { # name := (substring string 0 (1- index))
  1313.         var reg3 uintL count = index-1;
  1314.         var reg6 object name = allocate_string(count);
  1315.         var reg1 uintB* ptr2 = &TheSstring(name)->data[0];
  1316.         var reg2 uintB* ptr1 = &TheSstring(STACK_1)->data[0];
  1317.         dotimesL(count,count, { *ptr2++ = *ptr1++; } );
  1318.         STACK_1 = name;
  1319.       }
  1320.       name_type_ok: ;
  1321.     }
  1322. #endif
  1323.  
  1324. LISPFUN(parse_namestring,1,2,norest,key,3,\
  1325.         (kw(start),kw(end),kw(junk_allowed)) )
  1326. # (PARSE-NAMESTRING thing [host [defaults [:start] [:end] [:junk-allowed]]]),
  1327. # CLTL S. 414
  1328.   { # Stackaufbau: thing, host, defaults, start, end, junk-allowed.
  1329.     var reg6 boolean junk_allowed;
  1330.     var reg7 boolean parse_logical = FALSE;
  1331.     # 1. junk-allowed überprüfen:
  1332.     { var reg1 object obj = popSTACK(); # junk-allowed-Argument
  1333.       if (eq(obj,unbound))
  1334.         { junk_allowed = FALSE; }
  1335.         else
  1336.         if (nullp(obj)) { junk_allowed = FALSE; } else { junk_allowed = TRUE; }
  1337.     }
  1338.     # Stackaufbau: thing, host, defaults, start, end.
  1339.     # 2. Default-Wert für start ist 0:
  1340.     { if (eq(STACK_1,unbound)) { STACK_1 = Fixnum_0; }}
  1341.     # 3. host überprüfen:
  1342.     #if HAS_HOST || defined(LOGICAL_PATHNAMES)
  1343.     { var reg2 object host;
  1344.       #if HAS_HOST
  1345.       host = test_optional_host(STACK_3,FALSE);
  1346.       #else
  1347.       host = test_optional_host(STACK_3);
  1348.       #endif
  1349.       if (nullp(host))
  1350.         { # host := (PATHNAME-HOST defaults)
  1351.           var reg1 object defaults = test_default_pathname(STACK_2);
  1352.           #ifdef LOGICAL_PATHNAMES
  1353.           if (logpathnamep(defaults))
  1354.             { parse_logical = TRUE; host = TheLogpathname(defaults)->pathname_host; }
  1355.             else
  1356.           #endif
  1357.             {
  1358.               #if HAS_HOST
  1359.               host = ThePathname(defaults)->pathname_host;
  1360.               #else
  1361.               host = NIL;
  1362.               #endif
  1363.             }
  1364.         }
  1365.       #ifdef LOGICAL_PATHNAMES
  1366.       elif (logical_host_p(host))
  1367.         { parse_logical = TRUE; host = string_upcase(host); }
  1368.       #endif
  1369.       STACK_3 = host;
  1370.     }
  1371.     #else
  1372.     { test_optional_host(STACK_3); }
  1373.     #endif
  1374.     # 4. thing muß ein String sein:
  1375.     { var reg5 object thing = STACK_4;
  1376.       if (xpathnamep(thing)) # Pathname?
  1377.         { value1 = thing; # 1. Wert thing
  1378.           fertig:
  1379.           value2 = STACK_1; mv_count=2; # 2. Wert start
  1380.           skipSTACK(5); return;
  1381.         }
  1382.       if (streamp(thing)) # Stream?
  1383.         { thing = as_file_stream(thing);
  1384.           value1 = TheStream(thing)->strm_file_name; # 1. Wert: Filename
  1385.           goto fertig; # 2. Wert wie oben
  1386.         }
  1387.       # thing sollte nun wenigstens ein String oder Symbol sein:
  1388.       if (!stringp(thing))
  1389.         { if (!symbolp(thing)) { fehler_thing(thing); }
  1390.           thing = Symbol_name(thing); # Symbol -> Symbolname verwenden
  1391.           if (!parse_logical)
  1392.             {
  1393.               #if defined(PATHNAME_UNIX) || defined(PATHNAME_OS2) || defined(PATHNAME_RISCOS)
  1394.               # Betriebssystem mit Vorzug für Kleinbuchstaben
  1395.               thing = copy_string(thing); # ja -> mit STRING-DOWNCASE umwandeln
  1396.               nstring_downcase(&TheSstring(thing)->data[0],TheSstring(thing)->length);
  1397.               #endif
  1398.               #ifdef PATHNAME_AMIGAOS
  1399.               # Betriebssystem mit Vorzug für Capitalize
  1400.               thing = copy_string(thing); # ja -> mit STRING-CAPITALIZE umwandeln
  1401.               nstring_capitalize(&TheSstring(thing)->data[0],TheSstring(thing)->length);
  1402.               #endif
  1403.             }
  1404.           STACK_4 = thing; # und in den Stack zurückschreiben
  1405.         }
  1406.       # thing = STACK_4 ist jetzt ein String.
  1407.       { # Er wird durchlaufen.
  1408.         var zustand z; # laufender Zustand
  1409.         #ifdef PATHNAME_RISCOS
  1410.         # Hilfsvariablen zur Umsetzung eines new_thing-relativen FNindex
  1411.         # in einen thing-relativen FNindex.
  1412.         var object FNindex_limit = Fixnum_0;
  1413.         var sintL FNindex_offset = 0;
  1414.         var object FNindex_fallback;
  1415.         #endif
  1416.        {var object string; # String thing
  1417.         # Grenzen überprüfen, mit thing, start, end als Argumenten:
  1418.         pushSTACK(thing); pushSTACK(STACK_(1+1)); pushSTACK(STACK_(0+2));
  1419.         test_string_limits(&string,&z.index,&z.count);
  1420.         # z.index = Wert des start-Arguments,
  1421.         # z.count = Anzahl der Characters.
  1422.         z.FNindex = fixnum(z.index);
  1423.         # z.FNindex = start-Index als Fixnum.
  1424.         string = array_displace_check(string,z.count,&z.index); # Datenvektor holen,
  1425.         # z.index = Offset + Startindex = Startoffset
  1426.         pushSTACK(string);
  1427.        }
  1428.         #ifdef LOGICAL_PATHNAMES
  1429.         if (parse_logical)
  1430.           { pushSTACK(allocate_logpathname());
  1431.             # Stackaufbau: ..., Datenvektor, Pathname.
  1432.            {var reg1 uintL remaining = parse_logical_pathnamestring(z);
  1433.             z.index += z.count-remaining; z.FNindex = fixnum_inc(z.FNindex,z.count-remaining); z.count = remaining;
  1434.           }}
  1435.           else
  1436.         #endif
  1437.           {
  1438.             #ifdef PATHNAME_RISCOS
  1439.               # If the string starts with a system variable in <...> syntax,
  1440.               # then perform the substitution
  1441.               # (string-concat "<" var ">" tail) --> (string-concat (sys::getenv var) tail).
  1442.               if ((!(z.count==0)) && (TheSstring(STACK_0)->data[z.index] == '<'))
  1443.                 { var zustand startz = z; # Start-Zustand
  1444.                   var reg1 uintB ch;
  1445.                   # Character '<' übergehen:
  1446.                   z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1447.                   loop
  1448.                     { if (z.count==0) goto no_envvar;
  1449.                       ch = TheSstring(STACK_0)->data[z.index]; # nächstes Character
  1450.                       if (ch=='>') break;
  1451.                       if (!(graphic_char_p(ch) && !(ch=='*') && !(ch=='#'))) goto no_envvar;
  1452.                       # gültiges Character übergehen:
  1453.                       z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1454.                     }
  1455.                   FNindex_fallback = z.FNindex;
  1456.                   # Character '>' übergehen:
  1457.                   z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1458.                   # Environment-Variable als ASCIZ-String bauen:
  1459.                  {var reg4 object envvar;
  1460.                   { var reg3 uintL len = z.index - startz.index - 2;
  1461.                     if (len==0) goto no_envvar;
  1462.                     envvar = allocate_string(len+1);
  1463.                     # und füllen:
  1464.                    {var reg2 uintB* ptr1 = &TheSstring(STACK_0)->data[startz.index+1];
  1465.                     var reg1 uintB* ptr2 = &TheSstring(envvar)->data[0];
  1466.                     dotimesL(len,len, { *ptr2++ = *ptr1++; });
  1467.                     *ptr2 = '\0';
  1468.                   }}
  1469.                   # Dessen Wert holen:
  1470.                    begin_system_call();
  1471.                   {var reg1 const char* envval = getenv(TheAsciz(envvar));
  1472.                    end_system_call();
  1473.                    if (envval==NULL)
  1474.                      { pushSTACK(envvar);
  1475.                        pushSTACK(S(parse_namestring));
  1476.                        //: DEUTSCH "~: Es gibt keine Environment-Variable ~."
  1477.                        //: ENGLISH "~: there is no environment variable ~"
  1478.                        //: FRANCAIS "~ : Il n'y a pas de variable ~ dans l'environnement."
  1479.                        fehler(error, GETTEXT("~: there is no environment variable ~"));
  1480.                      }
  1481.                    pushSTACK(asciz_to_string(envval)); # Wert der Variablen als String
  1482.                  }}
  1483.                   # Reststück bilden:
  1484.                   { var reg4 uintL len = z.count;
  1485.                     var reg3 object tail = allocate_string(len);
  1486.                     var reg2 uintB* ptr1 = &TheSstring(STACK_1)->data[z.index];
  1487.                     var reg1 uintB* ptr2 = &TheSstring(tail)->data[0];
  1488.                     dotimesL(len,len, { *ptr2++ = *ptr1++; } );
  1489.                     pushSTACK(tail);
  1490.                   }
  1491.                   # Beides zusammenhängen, thing ersetzen:
  1492.                   { var reg2 uintL envval_len = TheSstring(STACK_1)->length;
  1493.                     var reg1 object new_thing = string_concat(2);
  1494.                     STACK_(4+1) = STACK_0 = new_thing;
  1495.                     # Der 2. Wert FNindex muß nachher noch modifiziert werden.
  1496.                     FNindex_limit = fixnum(envval_len);
  1497.                     FNindex_offset = (sintL)posfixnum_to_L(z.FNindex) - (sintL)envval_len;
  1498.                     z.index = 0; z.count = TheSstring(new_thing)->length; z.FNindex = Fixnum_0;
  1499.                   }
  1500.                   goto envvar_ok;
  1501.                  no_envvar: # keine Environment-Variable
  1502.                   z = startz; # zum Start zurück
  1503.                 }
  1504.               envvar_ok: ;
  1505.             #endif
  1506.             pushSTACK(allocate_pathname());
  1507.             # Stackaufbau: ..., Datenvektor, Pathname.
  1508.             #if HAS_HOST
  1509.               # Host-Specification parsen:
  1510.               {var reg3 object host;
  1511.                { var zustand startz = z; # Start-Zustand
  1512.                  var reg1 uintB ch;
  1513.                  #if defined(PATHNAME_RISCOS)
  1514.                    # Kommt eine Folge von Zeichen, eingeschlossen in '-',
  1515.                    # oder eine Folge von Zeichen und dann eine ':' ?
  1516.                    if (z.count==0) goto no_hostspec; # String schon zu Ende -> kein Host
  1517.                    ch = TheSstring(STACK_1)->data[z.index]; # nächstes Character
  1518.                    if (ch=='-')
  1519.                      { # '-' übergehen:
  1520.                        z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1521.                        loop
  1522.                          { if (z.count==0) goto no_hostspec; # String schon zu Ende -> kein Host
  1523.                            ch = TheSstring(STACK_1)->data[z.index]; # nächstes Character
  1524.                            if (ch=='-') break;
  1525.                            if (!legal_hostchar(ch)) goto no_hostspec;
  1526.                            # gültiges Character übergehen:
  1527.                            z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1528.                          }
  1529.                        # Host-String bilden:
  1530.                        { var reg4 uintL len = z.index - startz.index - 1;
  1531.                          if (len==0) goto no_hostspec;
  1532.                          host = allocate_string(len);
  1533.                          # und füllen:
  1534.                         {var reg2 uintB* ptr1 = &TheSstring(STACK_1)->data[startz.index+1];
  1535.                          var reg3 uintB* ptr2 = &TheSstring(host)->data[0];
  1536.                          dotimesL(len,len, { *ptr2++ = *ptr1++; });
  1537.                        }}
  1538.                      }
  1539.                      else
  1540.                      { loop
  1541.                          { if (!legal_hostchar(ch)) goto no_hostspec;
  1542.                            # gültiges Character übergehen:
  1543.                            z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1544.                            if (z.count==0) goto no_hostspec; # String schon zu Ende -> kein Host
  1545.                            ch = TheSstring(STACK_1)->data[z.index]; # nächstes Character
  1546.                            if (ch==':') break;
  1547.                          }
  1548.                        # Host-String bilden:
  1549.                        { var reg4 uintL len = z.index - startz.index;
  1550.                          host = allocate_string(len);
  1551.                          # und füllen:
  1552.                         {var reg2 uintB* ptr1 = &TheSstring(STACK_1)->data[startz.index];
  1553.                          var reg3 uintB* ptr2 = &TheSstring(host)->data[0];
  1554.                          dotimesL(len,len, { *ptr2++ = *ptr1++; });
  1555.                        }}
  1556.                      }
  1557.                    # Character '-' bzw. ':' übergehen:
  1558.                    z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1559.                    goto hostspec_ok;
  1560.                  #else
  1561.                    # Kommt eine Folge von alphanumerischen Zeichen und dann ein ':' bzw. '::' ?
  1562.                    loop
  1563.                      { if (z.count==0) goto no_hostspec; # String schon zu Ende -> kein Host
  1564.                        ch = TheSstring(STACK_1)->data[z.index]; # nächstes Character
  1565.                        if (!alphanumericp(ch)) break;
  1566.                        # alphanumerisches Character übergehen:
  1567.                        z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1568.                      }
  1569.                    if (!(ch==':')) goto no_hostspec; # kein ':' -> kein Host
  1570.                    # Host-String bilden:
  1571.                    { var reg4 uintL len = z.index - startz.index;
  1572.                      host = allocate_string(len);
  1573.                      # und füllen:
  1574.                     {var reg2 uintB* ptr1 = &TheSstring(STACK_1)->data[startz.index];
  1575.                      var reg3 uintB* ptr2 = &TheSstring(host)->data[0];
  1576.                      dotimesL(len,len, { *ptr2++ = *ptr1++; });
  1577.                    }}
  1578.                    # Character ':' übergehen:
  1579.                    z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1580.                    goto hostspec_ok;
  1581.                  #endif
  1582.                  no_hostspec: # keine Host-Specification
  1583.                    z = startz; # zum Start zurück
  1584.                    host = STACK_(3+2); # Default-Host
  1585.                }
  1586.                hostspec_ok:
  1587.                # Host eintragen:
  1588.                ThePathname(STACK_0)->pathname_host = host;
  1589.               }
  1590.             #endif
  1591.             #if HAS_DEVICE
  1592.              #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  1593.               # Einbuchstabige Device-Specification und evtl. Seriennummer parsen:
  1594.               {var reg3 object device = NIL; # Device := NIL
  1595.                # Drive-Specification parsen:
  1596.                # Kommt evtl. ein Buchstabe ('*','A'-'Z','a'-'z'), evtl. eine
  1597.                # Seriennummer (Integer >=0, <2^24) und dann ein ':' ?
  1598.                { var zustand startz = z; # Start-Zustand
  1599.                  var reg1 uintB ch;
  1600.                  if (z.count==0) goto no_drivespec; # String schon zu Ende ?
  1601.                  ch = TheSstring(STACK_1)->data[z.index]; # nächstes Character
  1602.                  ch = up_case(ch); # als Großbuchstabe
  1603.                  if (ch == '*')
  1604.                    # ch = '*' -> Device := :WILD
  1605.                    { device = S(Kwild); }
  1606.                  elif ((ch >= 'A') && (ch <= 'Z'))
  1607.                    # 'A' <= ch <= 'Z' -> Device := "ch"
  1608.                    { var reg1 object string = allocate_string(1); # String der Länge 1
  1609.                      TheSstring(string)->data[0] = ch; # mit ch als einzigem Buchstaben
  1610.                      device = string;
  1611.                    }
  1612.                  else goto no_device;
  1613.                  # Device OK, Character übergehen:
  1614.                  z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1615.                  if (z.count==0) goto no_drivespec; # String schon zu Ende ?
  1616.                  ch = TheSstring(STACK_1)->data[z.index]; # nächstes Character
  1617.                  ch = up_case(ch); # als Großbuchstabe
  1618.                  no_device:
  1619.                  # mit Doppelpunkt abgeschlossen?
  1620.                  if (!(ch == ':')) goto no_drivespec;
  1621.                  # Character übergehen:
  1622.                  z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1623.                  goto drivespec_ok;
  1624.                  no_drivespec:
  1625.                  # Es ist nicht gelungen, eine Drive-Specification zu parsen.
  1626.                  z = startz; # Start-Zustand wiederherstellen
  1627.                  device = NIL; # Device := NIL
  1628.                }
  1629.                drivespec_ok:
  1630.                ThePathname(STACK_0)->pathname_device = device; # Device eintragen
  1631.               }
  1632.              #endif
  1633.              #ifdef PATHNAME_AMIGAOS
  1634.               # Device-Specification parsen:
  1635.               {var reg3 object device;
  1636.                # Kommt eine nichtleere Folge von alphanumerischen Zeichen und dann ein ':' ?
  1637.                { var zustand startz = z; # Start-Zustand
  1638.                  var reg1 uintB ch;
  1639.                  loop
  1640.                    { if (z.count==0) goto no_devicespec; # String schon zu Ende -> kein Device
  1641.                      ch = TheSstring(STACK_1)->data[z.index]; # nächstes Character
  1642.                      if (!legal_namechar(ch)) break;
  1643.                      # alphanumerisches Character übergehen:
  1644.                      z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1645.                    }
  1646.                  if (!(ch==':')) goto no_devicespec; # kein ':' -> kein Device
  1647.                  if (z.index==startz.index) goto no_devicespec; # ':' am Anfang ist kein Device
  1648.                  # Device-String bilden:
  1649.                  { var reg4 uintL len = z.index - startz.index;
  1650.                    device = allocate_string(len);
  1651.                    # und füllen:
  1652.                   {var reg2 uintB* ptr1 = &TheSstring(STACK_1)->data[startz.index];
  1653.                    var reg3 uintB* ptr2 = &TheSstring(device)->data[0];
  1654.                    dotimesL(len,len, { *ptr2++ = *ptr1++; });
  1655.                  }}
  1656.                  # Character ':' nicht übergehen; das ergibt dann :ABSOLUTE.
  1657.                  goto devicespec_ok;
  1658.                  no_devicespec: # keine Device-Specification
  1659.                    z = startz; # zum Start zurück
  1660.                    device = NIL; # Device NIL
  1661.                }
  1662.                devicespec_ok:
  1663.                # Device eintragen:
  1664.                ThePathname(STACK_0)->pathname_device = device;
  1665.               }
  1666.              #endif
  1667.              #ifdef PATHNAME_RISCOS
  1668.               # Device-Specification parsen:
  1669.               {var reg3 object device;
  1670.                # Kommt ein ':', eine nichtleere Folge von Zeichen und dann ein '.' ?
  1671.                { var zustand startz = z; # Start-Zustand
  1672.                  var reg1 uintB ch;
  1673.                  if (z.count==0) goto no_devicespec; # String schon zu Ende -> kein Device
  1674.                  ch = TheSstring(STACK_1)->data[z.index]; # nächstes Character
  1675.                  if (!(ch==':')) goto no_devicespec; # kein ':' -> kein Device
  1676.                  # Character ':' übergehen:
  1677.                  z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1678.                  loop
  1679.                    { if (z.count==0) goto no_devicespec; # String schon zu Ende -> kein Device
  1680.                      ch = TheSstring(STACK_1)->data[z.index]; # nächstes Character
  1681.                      if (!(legal_namechar(ch) && !(ch=='*') && !singlewild_char_p(ch))) break;
  1682.                      # gültiges Character übergehen:
  1683.                      z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1684.                    }
  1685.                  if (!(ch=='.')) goto no_devicespec; # kein '.' -> kein Device
  1686.                  # Device-String bilden:
  1687.                  { var reg4 uintL len = z.index - startz.index - 1;
  1688.                    if (len==0) goto no_devicespec;
  1689.                    device = allocate_string(len);
  1690.                    # und füllen:
  1691.                   {var reg2 uintB* ptr1 = &TheSstring(STACK_1)->data[startz.index+1];
  1692.                    var reg3 uintB* ptr2 = &TheSstring(device)->data[0];
  1693.                    dotimesL(len,len, { *ptr2++ = *ptr1++; });
  1694.                  }}
  1695.                  # Character '.' übergehen:
  1696.                  z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1697.                  goto devicespec_ok;
  1698.                  no_devicespec: # keine Device-Specification
  1699.                    z = startz; # zum Start zurück
  1700.                    device = NIL; # Device NIL
  1701.                }
  1702.                devicespec_ok:
  1703.                # Device eintragen:
  1704.                ThePathname(STACK_0)->pathname_device = device;
  1705.               }
  1706.              #endif
  1707.             #endif
  1708.             # Directory-Start eintragen:
  1709.             { var reg1 object new_cons = allocate_cons(); # neues Cons für Startpoint
  1710.               ThePathname(STACK_0)->pathname_directory = new_cons;
  1711.               pushSTACK(new_cons); # neues (last (pathname-directory Pathname))
  1712.             }
  1713.             # Stackaufbau: ..., Datenvektor, Pathname, (last (pathname-directory Pathname)).
  1714.             # Subdirectories parsen:
  1715.             # Trennzeichen zwischen subdirs ist unter MSDOS sowohl '\' als auch '/':
  1716.             #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  1717.              #define slashp(c)  (((c) == '\\') || ((c) == '/'))
  1718.             #endif
  1719.             #if defined(PATHNAME_UNIX) || defined(PATHNAME_AMIGAOS)
  1720.              #define slashp(c)  ((c) == '/')
  1721.             #endif
  1722.             #ifdef PATHNAME_RISCOS
  1723.              #define slashp(c)  ((c) == '.')
  1724.             #endif
  1725.             {
  1726.               #if defined(USER_HOMEDIR) && defined(PATHNAME_UNIX)
  1727.               # Falls sofort ein '~' kommt, wird bis zum nächsten '/' oder Stringende
  1728.               # ein Username gelesen und das Home-Directory dieses Users eingesetzt:
  1729.               if ((!(z.count == 0)) && (TheSstring(STACK_2)->data[z.index] == '~'))
  1730.                 # Es kommt sofort ein '~'.
  1731.                 { # Character übergehen:
  1732.                   z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1733.                  {var reg6 object userhomedir; # Pathname des User-Homedir
  1734.                   # nächsten '/' suchen:
  1735.                   var reg2 uintB* charptr = &TheSstring(STACK_2)->data[z.index];
  1736.                   var reg3 uintL charcount = 0;
  1737.                   { var reg4 uintL count;
  1738.                     dotimesL(count,z.count,
  1739.                       { if (*charptr++ == '/') break;
  1740.                         charcount++;
  1741.                       });
  1742.                   }
  1743.                   # Username hat charcount Zeichen
  1744.                   if (charcount==0)
  1745.                     { userhomedir = O(user_homedir); } # nur '~' -> User-Homedir
  1746.                     else
  1747.                     { # Username als ASCIZ-String bauen:
  1748.                       var reg5 object username = allocate_string(charcount+1);
  1749.                       { var reg1 uintB* charptr2 = &TheSstring(username)->data[0];
  1750.                         var reg4 uintL count;
  1751.                         charptr = &TheSstring(STACK_2)->data[z.index];
  1752.                         dotimespL(count,charcount, { *charptr2++ = *charptr++; } );
  1753.                         *charptr2 = '\0';
  1754.                       }
  1755.                       # Dessen Home-Directory aus dem Passwort-File holen:
  1756.                       begin_system_call();
  1757.                       errno = 0;
  1758.                      {var reg1 struct passwd * userpasswd = getpwnam(TheAsciz(username));
  1759.                       end_system_call();
  1760.                       if (userpasswd == (struct passwd *)NULL) # erfolglos?
  1761.                         { if (!(errno==0)) { OS_error(); } # Error melden
  1762.                           # sonst: Fehler
  1763.                           pushSTACK(username);
  1764.                           pushSTACK(S(parse_namestring));
  1765.                           //: DEUTSCH "~: Es gibt keinen Benutzer mit Namen ~."
  1766.                           //: ENGLISH "~: there is no user named ~"
  1767.                           //: FRANCAIS "~ : Il n'y a pas d'utilisateur de nom ~."
  1768.                           fehler(error, GETTEXT("~: there is no user named ~"));
  1769.                         }
  1770.                       userhomedir = asciz_dir_to_pathname(userpasswd->pw_dir); # Homedir als Pathname
  1771.                     }}
  1772.                   # Directory aus dem Pathname userhomedir kopieren:
  1773.                   # (copy-list dir) = (nreconc (reverse dir) nil),
  1774.                   # dabei dessen letztes Cons merken.
  1775.                   userhomedir = reverse(ThePathname(userhomedir)->pathname_directory);
  1776.                   STACK_0 = userhomedir; userhomedir = nreconc(userhomedir,NIL);
  1777.                   ThePathname(STACK_1)->pathname_directory = userhomedir;
  1778.                   # username-Characters übergehen:
  1779.                   z.index += charcount; z.FNindex = fixnum_inc(z.FNindex,charcount); z.count -= charcount;
  1780.                   # Falls der String zu Ende ist: fertig,
  1781.                   # sonst kommt sofort ein '/', es wird übergangen:
  1782.                   if (z.count==0)
  1783.                     { pushSTACK(NIL); pushSTACK(NIL); goto after_name_type; } # Name und Typ := NIL
  1784.                   # Character übergehen:
  1785.                   z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1786.                 }}
  1787.               else
  1788.               #endif
  1789.               #if defined(PATHNAME_UNIX) && 0 # Wozu braucht man das, außer für $HOME ?
  1790.               # Falls sofort ein '$' kommt, wird bis zum nächsten '/' oder Stringende
  1791.               # eine Environment-Variable gelesen und ihr Wert eingesetzt:
  1792.               if ((!(z.count == 0)) && (TheSstring(STACK_2)->data[z.index] == '$'))
  1793.                 # Es kommt sofort ein '$'.
  1794.                 { # Character übergehen:
  1795.                   z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1796.                  {var reg6 object envval_dir;
  1797.                   # nächsten '/' suchen:
  1798.                   var reg2 uintB* charptr = &TheSstring(STACK_2)->data[z.index];
  1799.                   var reg3 uintL charcount = 0;
  1800.                   { var reg4 uintL count;
  1801.                     dotimesL(count,z.count,
  1802.                       { if (*charptr++ == '/') break;
  1803.                         charcount++;
  1804.                       });
  1805.                   }
  1806.                   # Environment-Variable hat charcount Zeichen,
  1807.                   # als ASCIZ-String bauen:
  1808.                   { var reg5 object envvar = allocate_string(charcount+1);
  1809.                     { var reg1 uintB* charptr2 = &TheSstring(envvar)->data[0];
  1810.                       var reg4 uintL count;
  1811.                       charptr = &TheSstring(STACK_2)->data[z.index];
  1812.                       dotimesL(count,charcount, { *charptr2++ = *charptr++; } );
  1813.                       *charptr2 = '\0';
  1814.                     }
  1815.                     # Dessen Wert holen:
  1816.                     begin_system_call();
  1817.                    {var reg1 const char* envval = getenv(TheAsciz(envvar));
  1818.                     end_system_call();
  1819.                     if (envval==NULL)
  1820.                       { pushSTACK(envvar);
  1821.                         pushSTACK(S(parse_namestring));
  1822.                         //: DEUTSCH "~: Es gibt keine Environment-Variable ~."
  1823.                         //: ENGLISH "~: there is no environment variable ~"
  1824.                         //: FRANCAIS "~ : Il n'y a pas de variable ~ dans l'environnement."
  1825.                         fehler(error, GETTEXT("~: there is no environment variable ~"));
  1826.                       }
  1827.                     envval_dir = asciz_dir_to_pathname(envval); # Wert der Variablen als Pathname
  1828.                   }}
  1829.                   # Directory aus dem Pathname envval_dir kopieren:
  1830.                   # (copy-list dir) = (nreconc (reverse dir) nil),
  1831.                   # dabei dessen letztes Cons merken.
  1832.                   envval_dir = reverse(ThePathname(envval_dir)->pathname_directory);
  1833.                   STACK_0 = envval_dir; envval_dir = nreconc(envval_dir,NIL);
  1834.                   ThePathname(STACK_1)->pathname_directory = envval_dir;
  1835.                   # envvar-Characters übergehen:
  1836.                   z.index += charcount; z.FNindex = fixnum_inc(z.FNindex,charcount); z.count -= charcount;
  1837.                   # Falls der String zu Ende ist: fertig,
  1838.                   # sonst kommt sofort ein '/', es wird übergangen:
  1839.                   if (z.count==0)
  1840.                     { pushSTACK(NIL); pushSTACK(NIL); goto after_name_type; } # Name und Typ := NIL
  1841.                   # Character übergehen:
  1842.                   z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1843.                 }}
  1844.               else
  1845.               #endif
  1846.               #if defined(PATHNAME_UNIX) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  1847.               # Falls sofort ein '\' bzw. '/' kommt, wird er übergangen, und es kommt
  1848.               # :ABSOLUTE (sonst :RELATIVE) als erstes subdir:
  1849.               if ((!(z.count == 0)) && slashp(TheSstring(STACK_2)->data[z.index]))
  1850.                 # Es kommt sofort ein '\' bzw. '/'.
  1851.                 { # Character übergehen:
  1852.                   z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1853.                   Car(STACK_0) = S(Kabsolute); # Startpoint = :ABSOLUTE
  1854.                 }
  1855.                 else
  1856.                 # Es kommt nicht sofort ein '\' bzw. '/'.
  1857.                 { Car(STACK_0) = S(Krelative); } # Startpoint = :RELATIVE
  1858.               #endif
  1859.               #ifdef PATHNAME_AMIGAOS
  1860.               # Falls sofort ein ':' kommt, wird er übergangen, und es kommt
  1861.               # :ABSOLUTE (sonst :RELATIVE) als erstes subdir:
  1862.               if ((!(z.count == 0)) && (TheSstring(STACK_2)->data[z.index] == ':'))
  1863.                 # Es kommt sofort ein ':'.
  1864.                 { # Character übergehen:
  1865.                   z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1866.                   Car(STACK_0) = S(Kabsolute); # directory = (:ABSOLUTE)
  1867.                 }
  1868.                 else
  1869.                 # Es kommt nicht sofort ein ':'.
  1870.                 { Car(STACK_0) = S(Krelative); } # directory = (:RELATIVE)
  1871.               #endif
  1872.               #ifdef PATHNAME_RISCOS
  1873.               # Präfix '$.' oder '&.' oder '@.' oder '%.' oder '\.' parsen.
  1874.               if ((z.count >= 2) && (TheSstring(STACK_2)->data[z.index+1] == '.'))
  1875.                 { switch (TheSstring(STACK_2)->data[z.index])
  1876.                     { case '$': Car(STACK_0) = S(Kroot); break; # directory = (:ABSOLUTE :ROOT)
  1877.                       case '&': Car(STACK_0) = S(Khome); break; # directory = (:ABSOLUTE :HOME)
  1878.                       case '@': Car(STACK_0) = S(Kcurrent); break; # directory = (:ABSOLUTE :CURRENT)
  1879.                       case '%': Car(STACK_0) = S(Klibrary); break; # directory = (:ABSOLUTE :LIBRARY)
  1880.                       case '\\': Car(STACK_0) = S(Kprevious); break; # directory = (:ABSOLUTE :PREVIOUS)
  1881.                       default: goto prefix_relative;
  1882.                     }
  1883.                   # Präfix übergehen:
  1884.                   z.index+=2; z.FNindex = fixnum_inc(z.FNindex,2); z.count-=2;
  1885.                   # (pathname-directory pathname) um ein Cons (:ABSOLUTE) verlängern:
  1886.                  {var reg1 object new_cons = allocate_cons(); # neues Cons
  1887.                   Car(new_cons) = S(Kabsolute); Cdr(new_cons) = STACK_0;
  1888.                   ThePathname(STACK_1)->pathname_directory = new_cons;
  1889.                 }}
  1890.                 else
  1891.                 prefix_relative:
  1892.                 { Car(STACK_0) = S(Krelative); } # directory = (:RELATIVE)
  1893.               #endif
  1894.               #if !defined(PATHNAME_RISCOS)
  1895.               loop
  1896.                 { # Versuche, ein weiteres Unterdirectory zu parsen.
  1897.                   #ifdef PATHNAME_EXT83
  1898.                     # Kommt '.\' oder '..\' oder '...\' ?
  1899.                     if ((!(z.count == 0)) && (TheSstring(STACK_2)->data[z.index] == '.'))
  1900.                       { # nächstes Character ist ein '.'.
  1901.                         var zustand subdirz = z; # Zustand beim Start des Subdirectories
  1902.                         # Character übergehen:
  1903.                         z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1904.                         if (z.count == 0) goto no_dots; # String schon zu Ende ?
  1905.                        {var reg1 uintB ch = TheSstring(STACK_2)->data[z.index]; # nächstes Character
  1906.                         if (slashp(ch))
  1907.                           # '.\' angetroffen -> (cons :CURRENT NIL) bauen
  1908.                           { pushSTACK(S(Kcurrent)); goto dots; }
  1909.                         if (!(ch == '.')) goto no_dots;
  1910.                         # zweites Character war auch ein '.'.
  1911.                         # Character übergehen:
  1912.                         z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1913.                         if (z.count == 0) goto no_dots; # String schon zu Ende ?
  1914.                         ch = TheSstring(STACK_2)->data[z.index]; # nächstes Character
  1915.                         if (slashp(ch))
  1916.                           # '..\' angetroffen -> (cons :PARENT NIL) bauen
  1917.                           { pushSTACK(S(Kparent)); goto dots; }
  1918.                         if (!(ch == '.')) goto no_dots;
  1919.                         # drittes Character war auch ein '.'.
  1920.                         # Character übergehen:
  1921.                         z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1922.                         if (z.count == 0) goto no_dots; # String schon zu Ende ?
  1923.                         ch = TheSstring(STACK_2)->data[z.index]; # nächstes Character
  1924.                         if (slashp(ch))
  1925.                           # '...\' angetroffen -> (cons :WILD-INFERIORS NIL) bauen
  1926.                           { pushSTACK(S(Kwild_inferiors)); goto dots; }
  1927.                         goto no_dots;
  1928.                        }
  1929.                         dots:
  1930.                         # '.\' oder '..\' oder '...\' angetroffen, Keyword im Stack.
  1931.                         # Character '\' übergehen:
  1932.                         z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1933.                         goto subdir_ok;
  1934.                         no_dots:
  1935.                         z = subdirz; # Zustand wiederherstellen
  1936.                       }
  1937.                     # Versuche, normale 'name.typ'-Syntax zu parsen:
  1938.                     pushSTACK(NIL); # dummy
  1939.                     { # Name, hat max. 8 Buchstaben:
  1940.                       var reg1 object name = parse_name_or_type(&z,8,NIL);
  1941.                       STACK_0 = name;
  1942.                     }
  1943.                     # Versuche, '.typ'-Syntax zu parsen:
  1944.                     { var reg1 object type;
  1945.                       if ((!(z.count==0)) && (TheSstring(STACK_3)->data[z.index] == '.'))
  1946.                         { # Es kommt ein '.'. Character übergehen:
  1947.                           z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1948.                           # Typ, hat max. 3 Buchstaben:
  1949.                           type = parse_name_or_type(&z,3,O(leer_string));
  1950.                         }
  1951.                         else
  1952.                         { type = NIL; }
  1953.                       pushSTACK(type);
  1954.                     }
  1955.                     # Stackaufbau: ...,
  1956.                     #   Datenvektor, Pathname, (last (pathname-directory Pathname)),
  1957.                     #   name, type.
  1958.                     # Kommt sofort ein '\', so war es ein Unterdirectory,
  1959.                     # sonst ist der Pathname beendet:
  1960.                     if ((z.count==0) || !slashp(TheSstring(STACK_4)->data[z.index])) break;
  1961.                     # Es kommt ein '\'. Character übergehen:
  1962.                     z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1963.                     # name=NIL -> durch "" ersetzen:
  1964.                     if (eq(STACK_1,NIL)) { STACK_1 = O(leer_string); }
  1965.                     # type=NIL -> durch "" ersetzen:
  1966.                     if (eq(STACK_0,NIL)) { STACK_0 = O(leer_string); }
  1967.                     { var reg1 object new_cons = allocate_cons(); # neues Cons
  1968.                       Cdr(new_cons) = popSTACK(); # type
  1969.                       Car(new_cons) = popSTACK(); # name
  1970.                       # new_cons = (cons name type)
  1971.                       pushSTACK(new_cons);
  1972.                     }
  1973.                     subdir_ok:
  1974.                   #endif
  1975.                   #ifdef PATHNAME_NOEXT
  1976.                     { var reg3 uintL z_start_index = z.index; # Index beim Start
  1977.                       loop
  1978.                         { var reg2 uintB ch;
  1979.                           if (z.count == 0) break;
  1980.                           ch = TheSstring(STACK_2)->data[z.index]; # nächstes Character
  1981.                           if (!legal_namechar(ch)) break; # gültiges Character ?
  1982.                           # ja -> Teil des Namens
  1983.                           # Character übergehen:
  1984.                           z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1985.                         }
  1986.                       # Ende des Namens erreicht.
  1987.                       # Name := Teilstring von STACK_2 von z_start_index (einschließlich)
  1988.                       #                                bis z.index (ausschließlich).
  1989.                      {var reg3 uintL len = z.index - z_start_index;
  1990.                       var reg4 object string = allocate_string(len); # String der Länge len
  1991.                       # füllen:
  1992.                       var reg1 uintB* ptr1 = &TheSstring(STACK_2)->data[z_start_index];
  1993.                       var reg2 uintB* ptr2 = &TheSstring(string)->data[0];
  1994.                       dotimesL(len,len, { *ptr2++ = *ptr1++; });
  1995.                       # Name fertig.
  1996.                       pushSTACK(string);
  1997.                     }}
  1998.                     # Kommt sofort ein '/' bzw. '\', so war es ein Unterdirectory,
  1999.                     # sonst ist der Pathname beendet:
  2000.                     if ((z.count==0) || !slashp(TheSstring(STACK_3)->data[z.index]))
  2001.                       # Nein -> war der Name und kein Subdir.
  2002.                       break;
  2003.                     # Es kommt ein '/' bzw. '\'. Character übergehen:
  2004.                     z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  2005.                     # Stackaufbau: ...,
  2006.                     #   Datenvektor, Pathname, (last (pathname-directory Pathname)),
  2007.                     #   subdir.
  2008.                     #ifdef PATHNAME_AMIGAOS
  2009.                     # War es '' ?
  2010.                     if (equal(STACK_0,O(leer_string)))
  2011.                       { STACK_0 = S(Kparent); } # ja -> durch :PARENT ersetzen
  2012.                     else
  2013.                     #endif
  2014.                     # War es '**' oder '...' ?
  2015.                     if (equal(STACK_0,O(wildwild_string)) || equal(STACK_0,O(punktpunktpunkt_string)))
  2016.                       { STACK_0 = S(Kwild_inferiors); } # ja -> durch :WILD-INFERIORS ersetzen
  2017.                   #endif
  2018.                   # (pathname-directory pathname) um Subdir STACK_0 verlängern:
  2019.                   { var reg1 object new_cons = allocate_cons(); # neues Cons
  2020.                     Car(new_cons) = popSTACK(); # = (cons subdir NIL)
  2021.                     Cdr(STACK_0) = new_cons; # verlängert (pathname-directory Pathname)
  2022.                     STACK_0 = new_cons; # neues (last (pathname-directory Pathname))
  2023.                   }
  2024.                 }
  2025.               #else # defined(PATHNAME_RISCOS)
  2026.               pushSTACK(unbound); # maybe-name
  2027.               # Stackaufbau: ..., Datenvektor, Pathname, (last (pathname-directory Pathname)),
  2028.               #              maybe-name.
  2029.               loop
  2030.                 { # Versuche, ein weiteres Unterdirectory zu parsen.
  2031.                   # Maybe-Name = die letzte gelesene Komponente in
  2032.                   # { { legal-wild char }+ | empty } '.'  Syntax.
  2033.                   # Ob ein weiteres subdir oder der Name, wird sich erst noch
  2034.                   # entscheiden.
  2035.                   # Kommt '^.' ?
  2036.                   if (!nullp(STACK_0)
  2037.                       && (z.count >= 2)
  2038.                       && (TheSstring(STACK_3)->data[z.index] == '^')
  2039.                       && slashp(TheSstring(STACK_3)->data[z.index+1])
  2040.                      )
  2041.                     { # beide Characters übergehen:
  2042.                       z.index+=2; z.FNindex = fixnum_inc(z.FNindex,2); z.count-=2;
  2043.                       pushSTACK(S(Kparent)); # :PARENT
  2044.                     }
  2045.                     else
  2046.                     # Versuche, normale  { legal-wild char }+  Syntax zu parsen:
  2047.                     { var reg3 uintL z_start_index = z.index; # Index beim Start des Namens
  2048.                       loop
  2049.                         { var reg2 uintB ch;
  2050.                           if (z.count == 0) break;
  2051.                           ch = TheSstring(STACK_3)->data[z.index]; # nächstes Character
  2052.                           if (!legal_namechar(ch)) break; # gültiges Character ?
  2053.                           # ja -> Teil des Namens
  2054.                           # Character übergehen:
  2055.                           z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  2056.                         }
  2057.                       # Ende des Namens erreicht.
  2058.                       # Name := Teilstring von STACK_3 von z_start_index (einschließlich)
  2059.                       #                                bis z.index (ausschließlich).
  2060.                      {var reg3 uintL len = z.index - z_start_index;
  2061.                       var reg4 object string;
  2062.                       if (len==0)
  2063.                         { string = NIL; } # "" wird zu NIL
  2064.                         else
  2065.                         { string = allocate_string(len); # String der Länge len
  2066.                           # füllen:
  2067.                          {var reg1 uintB* ptr1 = &TheSstring(STACK_3)->data[z_start_index];
  2068.                           var reg2 uintB* ptr2 = &TheSstring(string)->data[0];
  2069.                           dotimespL(len,len, { *ptr2++ = *ptr1++; });
  2070.                         }}
  2071.                       # Name fertig.
  2072.                       if (nullp(STACK_0)
  2073.                           || (z.count==0)
  2074.                           || !slashp(TheSstring(STACK_3)->data[z.index])
  2075.                          )
  2076.                         { pushSTACK(string); break; }
  2077.                       # Character '.' übergehen:
  2078.                       z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  2079.                       pushSTACK(string);
  2080.                     }}
  2081.                   if (!eq(STACK_1,unbound))
  2082.                     # (pathname-directory pathname) um Subdir STACK_1 verlängern:
  2083.                     { var reg1 object new_cons = allocate_cons(); # neues Cons
  2084.                       Car(new_cons) = STACK_1; # = (cons subdir NIL)
  2085.                       Cdr(STACK_2) = new_cons; # verlängert (pathname-directory Pathname)
  2086.                       STACK_2 = new_cons; # neues (last (pathname-directory Pathname))
  2087.                     }
  2088.                   STACK_1 = STACK_0; skipSTACK(1); # maybe-name := subdir
  2089.                 }
  2090.               if (eq(STACK_1,unbound)) { STACK_1 = STACK_0; STACK_0 = NIL; }
  2091.               # Stackaufbau: ..., Datenvektor, Pathname, (last (pathname-directory Pathname)),
  2092.               #              name, type.
  2093.               # In gewissen Fällen hört die Directory-Angabe nicht nach dem
  2094.               # vorletzten Punkt, sondern nach dem letzten Punkt auf:
  2095.               elif (eq(STACK_1,S(Kparent)) # z.B. "bar.^.foo"
  2096.                     || (nullp(STACK_0) && !nullp(STACK_1)) # z.B. "foo.bar."
  2097.                    )
  2098.                 # (pathname-directory pathname) um Subdir STACK_1 verlängern:
  2099.                 { var reg1 object new_cons = allocate_cons(); # neues Cons
  2100.                   Car(new_cons) = STACK_1; # = (cons subdir NIL)
  2101.                   Cdr(STACK_2) = new_cons; # verlängert (pathname-directory Pathname)
  2102.                   STACK_2 = new_cons; # neues (last (pathname-directory Pathname))
  2103.                   STACK_1 = STACK_0; # name := type
  2104.                   STACK_0 = NIL;     # type := NIL
  2105.                 }
  2106.               #endif
  2107.               #if defined(PATHNAME_EXT83) || defined(PATHNAME_RISCOS)
  2108.               # Stackaufbau: ...,
  2109.               #   Datenvektor, Pathname, (last (pathname-directory Pathname)),
  2110.               #   name, type.
  2111.               # Name und Typ in Pathname eintragen:
  2112.               { var reg3 object type = popSTACK();
  2113.                 var reg2 object name = popSTACK();
  2114.                 skipSTACK(1); # Directory ist schon eingetragen
  2115.                {var reg1 object pathname = STACK_0;
  2116.                 ThePathname(pathname)->pathname_name = name;
  2117.                 ThePathname(pathname)->pathname_type = type;
  2118.               }}
  2119.               #endif
  2120.               #ifdef PATHNAME_NOEXT
  2121.               # Stackaufbau: ..., Datenvektor, Pathname, (last (pathname-directory Pathname)),
  2122.               #              string.
  2123.               split_name_type(sym_nullp(S(read_pathname_p))); # String STACK_0 in Name und Typ aufspalten
  2124.               after_name_type:
  2125.               # Stackaufbau: ..., Datenvektor, Pathname, (last (pathname-directory Pathname)),
  2126.               #              name, type.
  2127.               # Name und Typ in Pathname eintragen:
  2128.               { var reg3 object type = popSTACK();
  2129.                 var reg2 object name = popSTACK();
  2130.                 skipSTACK(1); # Directory ist schon eingetragen
  2131.                 # name="" durch Name=NIL ersetzen:
  2132.                 if (equal(name,O(leer_string))) { name = NIL; }
  2133.                {var reg1 object pathname = STACK_0;
  2134.                 ThePathname(pathname)->pathname_name = name;
  2135.                 ThePathname(pathname)->pathname_type = type;
  2136.               }}
  2137.               #endif
  2138.             }
  2139.             #undef slashp
  2140.           }
  2141.         # Pathname fertig.
  2142.         # Stackaufbau: ..., Datenvektor, Pathname.
  2143.         if (!junk_allowed)
  2144.           # Überprüfen, ob keine Zeichen mehr übrig sind:
  2145.           if (!(z.count == 0))
  2146.             { pushSTACK(z.FNindex); # letzter Index
  2147.               pushSTACK(STACK_(4+2+1)); # thing
  2148.               pushSTACK(S(parse_namestring));
  2149.               //: DEUTSCH "~: Syntax Error im Dateinamen ~ an Position ~."
  2150.               //: ENGLISH "~: syntax error in filename ~ at position ~"
  2151.               //: FRANCAIS "~ : Erreur de syntaxe dans le nom de fichier ~, à la position ~."
  2152.               fehler(error, GETTEXT("~: syntax error in filename ~ at position ~"));
  2153.             }
  2154.         #ifdef LOGICAL_PATHNAMES
  2155.         if (parse_logical)
  2156.           { if (!nullp(STACK_(3+2)))
  2157.               # Hosts müssen übereinstimmen, vgl. CLtL2 S. 629
  2158.               if (!equal(STACK_(3+2),TheLogpathname(STACK_0)->pathname_host))
  2159.                 { pushSTACK(STACK_0);
  2160.                   pushSTACK(TheLogpathname(STACK_(0+1))->pathname_host);
  2161.                   pushSTACK(STACK_(3+2+2));
  2162.                   pushSTACK(S(parse_namestring));
  2163.                   //: DEUTSCH "~: Hosts ~ und ~ von ~ stimmen nicht überein."
  2164.                   //: ENGLISH "~: hosts ~ and ~ of ~ should coincide"
  2165.                   //: FRANCAIS "~ : Les «hosts» ~ et ~ de ~ ne sont pas les mêmes."
  2166.                   fehler(error, GETTEXT("~: hosts ~ and ~ of ~ should coincide"));
  2167.           }     }
  2168.         #endif
  2169.         value1 = STACK_0; # Pathname als 1. Wert
  2170.         #ifdef PATHNAME_RISCOS
  2171.         if (as_oint(z.FNindex) >= as_oint(FNindex_limit))
  2172.           # FNindex von new_thing nach thing umrechnen:
  2173.           { value2 = fixnum_inc(z.FNindex,FNindex_offset); }
  2174.           else
  2175.           # FNindex zeigt in den ersetzten (!) String envval. Was bleibt
  2176.           # uns als Index anderes übrig als der Start-Index?
  2177.           # (Nicht ganz korrekt freilich: Hätte das Parsen wirklich dort
  2178.           # aufgehört, würde value1 anders aussehen!)
  2179.           # Zum Beispiel ein Index in das Innere des <...>-Konstruktes.
  2180.           # (Auch das ist nicht ganz korrekt, kommt der Sache aber näher.)
  2181.           { value2 = FNindex_fallback; }
  2182.         #else
  2183.         value2 = z.FNindex; # Index als 2. Wert
  2184.         #endif
  2185.         mv_count=2; # 2 Werte
  2186.         skipSTACK(5+2); return;
  2187.   } } }
  2188.  
  2189. # UP: Wandelt ein Objekt in einen Pathname um.
  2190. # coerce_xpathname(object)
  2191. # > object: Objekt
  2192. # < ergebnis: (PATHNAME Objekt)
  2193. # kann GC auslösen
  2194.   local object coerce_xpathname (object obj);
  2195.   local object coerce_xpathname(obj)
  2196.     var reg1 object obj;
  2197.     { if (xpathnamep(obj))
  2198.         # Bei Pathnames ist nichts zu tun.
  2199.         { return obj; }
  2200.         else
  2201.         # sonst: PARSE-NAMESTRING aufrufen:
  2202.         { pushSTACK(subr_self); # subr_self retten (für spätere Fehlermeldungen)
  2203.           pushSTACK(obj); funcall(L(parse_namestring),1);
  2204.           subr_self = popSTACK();
  2205.           return value1;
  2206.         }
  2207.     }
  2208.  
  2209. LISPFUNN(pathname,1)
  2210. # (PATHNAME pathname), CLTL S. 413
  2211.   { value1 = coerce_xpathname(popSTACK()); mv_count=1; }
  2212.  
  2213. LISPFUN(pathnamehost,1,0,norest,key,1, (kw(case)))
  2214. # (PATHNAME-HOST pathname), CLTL S. 417, CLtL2 S. 644
  2215.   { var reg1 object pathname = coerce_xpathname(STACK_1);
  2216.     #ifdef LOGICAL_PATHNAMES
  2217.     if (logpathnamep(pathname))
  2218.       { value1 = TheLogpathname(pathname)->pathname_host; mv_count=1; }
  2219.       else
  2220.     #endif
  2221.       {
  2222.         #if HAS_HOST
  2223.         var reg2 object erg = ThePathname(pathname)->pathname_host;
  2224.         value1 = (eq(STACK_0,S(Kcommon)) ? common_case(erg) : erg);
  2225.         mv_count=1; # host als Wert
  2226.         #else
  2227.         value1 = NIL; mv_count=1; # NIL als Wert
  2228.         #endif
  2229.       }
  2230.     skipSTACK(2);
  2231.   }
  2232.  
  2233. LISPFUN(pathnamedevice,1,0,norest,key,1, (kw(case)))
  2234. # (PATHNAME-DEVICE pathname), CLTL S. 417, CLtL2 S. 644
  2235.   { var reg1 object pathname = coerce_xpathname(STACK_1);
  2236.     #ifdef LOGICAL_PATHNAMES
  2237.     if (logpathnamep(pathname))
  2238.       { value1 = NIL; mv_count=1; }
  2239.       else
  2240.     #endif
  2241.       {
  2242.         #if HAS_DEVICE
  2243.         var reg2 object erg = ThePathname(pathname)->pathname_device;
  2244.         value1 = (eq(STACK_0,S(Kcommon)) ? common_case(erg) : erg);
  2245.         mv_count=1; # device als Wert
  2246.         #else
  2247.         value1 = NIL; mv_count=1; # NIL als Wert
  2248.         #endif
  2249.       }
  2250.     skipSTACK(2);
  2251.   }
  2252.  
  2253. LISPFUN(pathnamedirectory,1,0,norest,key,1, (kw(case)))
  2254. # (PATHNAME-DIRECTORY pathname), CLTL S. 417, CLtL2 S. 644
  2255.   { var reg1 object pathname = coerce_xpathname(STACK_1);
  2256.     #ifdef LOGICAL_PATHNAMES
  2257.     if (logpathnamep(pathname))
  2258.       { value1 = TheLogpathname(pathname)->pathname_directory; }
  2259.       else
  2260.     #endif
  2261.       { var reg2 object erg = ThePathname(pathname)->pathname_directory;
  2262.         value1 = (eq(STACK_0,S(Kcommon)) ? subst_common_case(erg) : erg);
  2263.       }
  2264.     mv_count=1; # directory als Wert
  2265.     skipSTACK(2);
  2266.   }
  2267.  
  2268. LISPFUN(pathnamename,1,0,norest,key,1, (kw(case)))
  2269. # (PATHNAME-NAME pathname), CLTL S. 417, CLtL2 S. 644
  2270.   { var reg1 object pathname = coerce_xpathname(STACK_1);
  2271.     #ifdef LOGICAL_PATHNAMES
  2272.     if (logpathnamep(pathname))
  2273.       { value1 = TheLogpathname(pathname)->pathname_name; }
  2274.       else
  2275.     #endif
  2276.       { var reg2 object erg = ThePathname(pathname)->pathname_name;
  2277.         value1 = (eq(STACK_0,S(Kcommon)) ? common_case(erg) : erg);
  2278.       }
  2279.     mv_count=1; # name als Wert
  2280.     skipSTACK(2);
  2281.   }
  2282.  
  2283. LISPFUN(pathnametype,1,0,norest,key,1, (kw(case)))
  2284. # (PATHNAME-TYPE pathname), CLTL S. 417, CLtL2 S. 644
  2285.   { var reg1 object pathname = coerce_xpathname(STACK_1);
  2286.     #ifdef LOGICAL_PATHNAMES
  2287.     if (logpathnamep(pathname))
  2288.       { value1 = TheLogpathname(pathname)->pathname_type; }
  2289.       else
  2290.     #endif
  2291.       { var reg2 object erg = ThePathname(pathname)->pathname_type;
  2292.         value1 = (eq(STACK_0,S(Kcommon)) ? common_case(erg) : erg);
  2293.       }
  2294.     mv_count=1; # type als Wert
  2295.     skipSTACK(2);
  2296.   }
  2297.  
  2298. LISPFUNN(pathnameversion,1)
  2299. # (PATHNAME-VERSION pathname), CLTL S. 417, CLtL2 S. 644
  2300.   { var reg1 object pathname = coerce_xpathname(popSTACK());
  2301.     #ifdef LOGICAL_PATHNAMES
  2302.     if (logpathnamep(pathname))
  2303.       { value1 = TheLogpathname(pathname)->pathname_version; }
  2304.       else
  2305.     #endif
  2306.       {
  2307.         #if HAS_VERSION
  2308.         value1 = ThePathname(pathname)->pathname_version; # version als Wert
  2309.         #else
  2310.         value1 = NIL; # NIL als Wert
  2311.         #endif
  2312.       }
  2313.     mv_count=1;
  2314.   }
  2315.  
  2316. # Zugriffsfunktionen ohne Groß-/Klein-Umwandlung:
  2317. # xpathname_host(logical,pathname)
  2318. # xpathname_device(logical,pathname)
  2319. # xpathname_directory(logical,pathname)
  2320. # xpathname_name(logical,pathname)
  2321. # xpathname_type(logical,pathname)
  2322. # xpathname_version(logical,pathname)
  2323. # > pathname: Pathname oder Logical Pathname
  2324. # > logical: Flag, ob es sich um einen Logical Pathname handelt
  2325. # < ergebnis: Wert der entsprechenden Komponente von pathname
  2326.   #ifdef LOGICAL_PATHNAMES
  2327.     #if HAS_HOST
  2328.       #define xpathname_host(logical,pathname)  \
  2329.         (logical ? TheLogpathname(pathname)->pathname_host : ThePathname(pathname)->pathname_host)
  2330.     #else
  2331.       #define xpathname_host(logical,pathname)  \
  2332.         (logical ? TheLogpathname(pathname)->pathname_host : NIL)
  2333.     #endif
  2334.     #if HAS_DEVICE
  2335.       #define xpathname_device(logical,pathname)  \
  2336.         (logical ? NIL : ThePathname(pathname)->pathname_device)
  2337.     #else
  2338.       #define xpathname_device(logical,pathname)  NIL
  2339.     #endif
  2340.     #define xpathname_directory(logical,pathname)  \
  2341.       (logical ? TheLogpathname(pathname)->pathname_directory : ThePathname(pathname)->pathname_directory)
  2342.     #define xpathname_name(logical,pathname)  \
  2343.       (logical ? TheLogpathname(pathname)->pathname_name : ThePathname(pathname)->pathname_name)
  2344.     #define xpathname_type(logical,pathname)  \
  2345.       (logical ? TheLogpathname(pathname)->pathname_type : ThePathname(pathname)->pathname_type)
  2346.     #if HAS_VERSION
  2347.       #define xpathname_version(logical,pathname)  \
  2348.         (logical ? TheLogpathname(pathname)->pathname_version : ThePathname(pathname)->pathname_version)
  2349.     #else
  2350.       #define xpathname_version(logical,pathname)  \
  2351.         (logical ? TheLogpathname(pathname)->pathname_version : NIL)
  2352.     #endif
  2353.   #else
  2354.     # logical immer =FALSE
  2355.     #if HAS_HOST
  2356.       #define xpathname_host(logical,pathname)  ThePathname(pathname)->pathname_host
  2357.     #else
  2358.       #define xpathname_host(logical,pathname)  NIL
  2359.     #endif
  2360.     #if HAS_DEVICE
  2361.       #define xpathname_device(logical,pathname)  ThePathname(pathname)->pathname_device
  2362.     #else
  2363.       #define xpathname_device(logical,pathname)  NIL
  2364.     #endif
  2365.     #define xpathname_directory(logical,pathname)  ThePathname(pathname)->pathname_directory
  2366.     #define xpathname_name(logical,pathname)  ThePathname(pathname)->pathname_name
  2367.     #define xpathname_type(logical,pathname)  ThePathname(pathname)->pathname_type
  2368.     #if HAS_VERSION
  2369.       #define xpathname_version(logical,pathname)  ThePathname(pathname)->pathname_version
  2370.     #else
  2371.       #define xpathname_version(logical,pathname)  NIL
  2372.     #endif
  2373.   #endif
  2374.  
  2375. #ifdef LOGICAL_PATHNAMES
  2376.  
  2377. LISPFUNN(logical_pathname,1)
  2378. # (LOGICAL-PATHNAME thing), CLtL2 S. 631
  2379.   { var reg1 object thing = popSTACK();
  2380.     if (logpathnamep(thing))
  2381.       # Bei Logical Pathnames ist nichts zu tun.
  2382.       { value1 = thing; mv_count=1; }
  2383.     elif (pathnamep(thing))
  2384.       # Normale Pathnames können nicht in Logical Pathnames umgewandelt werden.
  2385.       { pushSTACK(thing); # Wert für Slot DATUM von TYPE-ERROR
  2386.         pushSTACK(O(type_logical_pathname)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  2387.         pushSTACK(thing);
  2388.         pushSTACK(S(logical_pathname));
  2389.         //: DEUTSCH "~: Argument ~ ist kein Logical Pathname, String, Stream oder Symbol."
  2390.         //: ENGLISH "~: argument ~ is not a logical pathname, string, stream or symbol"
  2391.         //: FRANCAIS "~ : L'argument ~ n'est pas un «pathname logique», une chaîne, un «stream» ou un symbole."
  2392.         fehler(type_error, GETTEXT("~: argument ~ is not a logical pathname, string, stream or symbol"));
  2393.       }
  2394.     else
  2395.       # sonst: PARSE-NAMESTRING aufrufen:
  2396.       { pushSTACK(subr_self); # subr_self retten (für spätere Fehlermeldungen)
  2397.         # Das Ergebnis von (PARSE-NAMESTRING thing nil empty-logical-pathname)
  2398.         # ist garantiert ein logischer Pathname.
  2399.         pushSTACK(thing); pushSTACK(NIL); pushSTACK(O(empty_logical_pathname));
  2400.         funcall(L(parse_namestring),3);
  2401.         subr_self = popSTACK();
  2402.         mv_count=1;
  2403.       }
  2404.   }
  2405.  
  2406. LISPFUN(translate_logical_pathname,1,0,norest,key,0,_EMA_)
  2407. # (TRANSLATE-LOGICAL-PATHNAME pathname &key), CLtL2 S. 631
  2408.   { var reg3 object pathname;
  2409.     funcall(L(logical_pathname),1);
  2410.     pathname = value1;
  2411.     if (logpathnamep(pathname))
  2412.       { # Umwandeln eines logischen in einen normalen Pathname:
  2413.         # (let ((ht (make-hash-table :test #'equal)))
  2414.         #   (loop
  2415.         #     (when (gethash pathname ht) (error "Translation loop"))
  2416.         #     (setf (gethash pathname ht) t)
  2417.         #     (let ((host (or (pathname-host pathname) "SYS")))
  2418.         #       (unless (logical-host-p host) (error "No translation for host"))
  2419.         #       (let* ((translations (gethash host sys::*logical-pathname-translations*))
  2420.         #              (translation (assoc pathname translations :test #'pathname-match-p)))
  2421.         #         (unless (and translation (consp translation) (consp (cdr translation)))
  2422.         #           (error "No translation for pathname")
  2423.         #         )
  2424.         #         (setq pathname (translate-pathname pathname (first translation) (second translation)))
  2425.         #     ) )
  2426.         #     (unless (sys::logical-pathname-p pathname) (return))
  2427.         #   )
  2428.         #   pathname
  2429.         # )
  2430.         pushSTACK(pathname);
  2431.         pushSTACK(S(Ktest)); pushSTACK(L(equal)); funcall(L(make_hash_table),2);
  2432.         pushSTACK(value1);
  2433.         # Stackaufbau: pathname, ht.
  2434.         loop
  2435.           { if (!nullp(shifthash(STACK_0,STACK_1,T)))
  2436.               { # STACK_1 = pathname; # Wert für Slot PATHNAME von FILE-ERROR
  2437.                 STACK_0 = STACK_1;
  2438.                 pushSTACK(S(translate_logical_pathname));
  2439.                 //: DEUTSCH "~: Endlosschleife beim Auflösen von ~"
  2440.                 //: ENGLISH "~: endless loop while resolving ~"
  2441.                 //: FRANCAIS "~ : boucle infinie pour ~"
  2442.                 fehler(file_error, GETTEXT("~: endless loop while resolving ~"));
  2443.               }
  2444.             if (nullp(TheLogpathname(STACK_1)->pathname_host))
  2445.               # Host NIL durch Default-Host ersetzen:
  2446.               { var reg1 object new = allocate_logpathname();
  2447.                 var reg2 object old = STACK_1;
  2448.                 TheLogpathname(new)->pathname_host      = O(default_logical_pathname_host); # Default "SYS"
  2449.                 TheLogpathname(new)->pathname_directory = TheLogpathname(old)->pathname_directory;
  2450.                 TheLogpathname(new)->pathname_name      = TheLogpathname(old)->pathname_name;
  2451.                 TheLogpathname(new)->pathname_type      = TheLogpathname(old)->pathname_type;
  2452.                 TheLogpathname(new)->pathname_version   = TheLogpathname(old)->pathname_version;
  2453.                 STACK_1 = new;
  2454.               }
  2455.            {var reg2 object host = TheLogpathname(STACK_1)->pathname_host;
  2456.             var reg1 object translations = gethash(host,Symbol_value(S(logpathname_translations)));
  2457.             if (eq(translations,nullobj))
  2458.               { # STACK_1 = pathname; # Wert für Slot PATHNAME von FILE-ERROR
  2459.                 STACK_0 = STACK_1;
  2460.                 pushSTACK(host);
  2461.                 pushSTACK(S(translate_logical_pathname));
  2462.                 //: DEUTSCH "~: Logical Host ~ ist unbekannt: ~"
  2463.                 //: ENGLISH "~: unknown logical host ~ in ~"
  2464.                 //: FRANCAIS "~ : host ~ inconnu dans ~"
  2465.                 fehler(file_error, GETTEXT("~: unknown logical host ~ in ~"));
  2466.               }
  2467.             # (ASSOC pathname translations :test #'pathname-match-p):
  2468.             pushSTACK(STACK_1); pushSTACK(translations);
  2469.             pushSTACK(S(Ktest)); pushSTACK(L(pathname_match_p));
  2470.             funcall(L(assoc),4);
  2471.             if (atomp(value1) || matomp(Cdr(value1)))
  2472.               { # STACK_1 = pathname; # Wert für Slot PATHNAME von FILE-ERROR
  2473.                 STACK_0 = STACK_1;
  2474.                 pushSTACK(S(translate_logical_pathname));
  2475.                 //: DEUTSCH "~: Keine Ersetzungsregel für ~ ist bekannt."
  2476.                 //: ENGLISH "~: No replacement rule for ~ is known."
  2477.                 //: FRANCAIS "~ : Aucune règle de traduction est connue pour ~."
  2478.                 fehler(file_error, GETTEXT("~: No replacement rule for ~ is known."));
  2479.               }
  2480.             # (TRANSLATE-PATHNAME pathname (first rule) (second rule) :MERGE NIL):
  2481.             pushSTACK(STACK_1); pushSTACK(Car(value1)); pushSTACK(Car(Cdr(value1)));
  2482.             pushSTACK(S(Kmerge)); pushSTACK(NIL);
  2483.             funcall(L(translate_pathname),5);
  2484.             STACK_1 = pathname = value1;
  2485.             if (!logpathnamep(pathname)) break;
  2486.           }}
  2487.         skipSTACK(2);
  2488.       }
  2489.     value1 = pathname; mv_count=1;
  2490.   }
  2491.  
  2492. # UP: Wandelt ein Objekt in einen nicht-Logical Pathname um.
  2493. # coerce_pathname(object)
  2494. # > object: Objekt
  2495. # < ergebnis: (TRANSLATE-LOGICAL-PATHNAME (PATHNAME Objekt))
  2496. # kann GC auslösen
  2497.   local object coerce_pathname (object obj);
  2498.   local object coerce_pathname(obj)
  2499.     var reg1 object obj;
  2500.     { obj = coerce_xpathname(obj);
  2501.       if (pathnamep(obj))
  2502.         # Bei Pathnames ist nichts zu tun.
  2503.         { return obj; }
  2504.       elif (logpathnamep(obj))
  2505.         # TRANSLATE-LOGICAL-PATHNAME aufrufen:
  2506.         { pushSTACK(subr_self); # subr_self retten (für spätere Fehlermeldungen)
  2507.           pushSTACK(obj); funcall(L(translate_logical_pathname),1);
  2508.           subr_self = popSTACK();
  2509.           return value1;
  2510.         }
  2511.       else
  2512.         { NOTREACHED }
  2513.     }
  2514.  
  2515. #endif
  2516.  
  2517. # UP: Legt Teilstrings für STRING_CONCAT auf den STACK, die zusammen den
  2518. # String für ein Subdirectory (car path) ergeben.
  2519. # subdir_namestring_parts(path)
  2520. # > path: ein Cons
  2521. # < ergebnis: Anzahl der auf den Stack gelegten Strings
  2522. # verändert STACK
  2523.   local uintC subdir_namestring_parts (object path);
  2524.   local uintC subdir_namestring_parts(path)
  2525.     var reg4 object path;
  2526.     { var reg1 object subdir = Car(path);
  2527.       #if defined(PATHNAME_MSDOS)
  2528.       if (eq(subdir,S(Kcurrent))) # :CURRENT ?
  2529.         { pushSTACK(O(punkt_string)); return 1; }
  2530.       elif (eq(subdir,S(Kparent))) # :PARENT ?
  2531.         { pushSTACK(O(punktpunkt_string)); return 1; }
  2532.       elif (eq(subdir,S(Kwild_inferiors))) # :WILD-INFERIORS ?
  2533.         { pushSTACK(O(punktpunktpunkt_string)); return 1; }
  2534.       else
  2535.         # normales subdir (name . type)
  2536.         { var reg3 object name = Car(subdir);
  2537.           var reg2 object type = Cdr(subdir);
  2538.           # name = :WILD -> String "*"
  2539.           if (eq(name,S(Kwild))) { name = O(wild_string); }
  2540.           pushSTACK(name);
  2541.           # type = :WILD -> String "*"
  2542.           if (eq(type,S(Kwild))) { type = O(wild_string); }
  2543.           if (TheSstring(type)->length == 0)
  2544.             # type = "" -> nicht auszugeben
  2545.             { return 1+0; }
  2546.             else
  2547.             { pushSTACK(O(punkt_string)); # "."
  2548.               pushSTACK(type);
  2549.               return 1+2;
  2550.             }
  2551.         }
  2552.       #endif
  2553.       #ifdef PATHNAME_AMIGAOS
  2554.       if (eq(subdir,S(Kparent))) # :PARENT ?
  2555.         { return 0; } # Leerstring
  2556.       elif (eq(subdir,S(Kwild_inferiors))) # :WILD-INFERIORS ?
  2557.         { pushSTACK(O(wildwild_string)); return 1; }
  2558.       else
  2559.         # normales subdir
  2560.         { pushSTACK(subdir); return 1; }
  2561.       #endif
  2562.       #if defined(PATHNAME_UNIX) || defined(PATHNAME_OS2)
  2563.       if (eq(subdir,S(Kwild_inferiors))) # :WILD-INFERIORS ?
  2564.         { pushSTACK(O(wildwild_string)); return 1; }
  2565.         else
  2566.         # normales subdir
  2567.         { pushSTACK(subdir); return 1; }
  2568.       #endif
  2569.       #ifdef PATHNAME_RISCOS
  2570.       if (eq(subdir,S(Kparent))) # :PARENT ?
  2571.         { pushSTACK(O(parent_string)); return 1; }
  2572.         else
  2573.         # normales subdir
  2574.         { pushSTACK(subdir); return 1; }
  2575.       #endif
  2576.     }
  2577.  
  2578. # UP: Legt Teilstrings für STRING_CONCAT auf den STACK, die zusammen den
  2579. # String für den Host des Pathname pathname ergeben.
  2580. # host_namestring_parts(pathname)
  2581. # > pathname: nicht-Logical Pathname
  2582. # < ergebnis: Anzahl der auf den Stack gelegten Strings
  2583. # verändert STACK
  2584. #if HAS_HOST
  2585.   local uintC host_namestring_parts (object pathname);
  2586.   local uintC host_namestring_parts(pathname)
  2587.     var reg1 object pathname;
  2588.     { var reg2 object host = ThePathname(pathname)->pathname_host;
  2589.       if (nullp(host))
  2590.         { return 0; } # kein String
  2591.         else
  2592.         { pushSTACK(host);
  2593.           pushSTACK(O(doppelpunkt_string)); # ":"
  2594.           return 2;
  2595.     }   }
  2596. #else
  2597.   #define host_namestring_parts(pathname)  (unused (pathname), 0)  # keine Strings
  2598. #endif
  2599.  
  2600. # UP: Legt Teilstrings für STRING_CONCAT auf den STACK, die zusammen den
  2601. # String fürs Device und Directory des Pathname pathname ergeben.
  2602. # directory_namestring_parts(pathname)
  2603. # > pathname: nicht-Logical Pathname
  2604. # < ergebnis: Anzahl der auf den Stack gelegten Strings
  2605. # verändert STACK
  2606.   local uintC directory_namestring_parts (object pathname);
  2607.   local uintC directory_namestring_parts(pathname)
  2608.     var reg4 object pathname;
  2609.     { var reg3 uintC stringcount = 0; # bisherige Stringzahl = 0
  2610.       #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  2611.       # Device:
  2612.       { var reg1 object device = ThePathname(pathname)->pathname_device;
  2613.         if (!(nullp(device))) # NIL -> kein String
  2614.           { if (eq(device,S(Kwild))) { device = O(wild_string); } # :WILD -> String "*"
  2615.             pushSTACK(device); # Device auf den Stack
  2616.             stringcount++; # und mitzählen
  2617.       }   }
  2618.       #endif
  2619.       #ifdef PATHNAME_AMIGAOS
  2620.       # Device:
  2621.       { var reg1 object device = ThePathname(pathname)->pathname_device;
  2622.         if (!(nullp(device))) # NIL -> kein String
  2623.           { pushSTACK(device); # Device auf den Stack
  2624.             stringcount += 1; # und mitzählen
  2625.             # Wegen :ABSOLUTE kommt gleich danach ein ":" auf den Stack.
  2626.       }   }
  2627.       #endif
  2628.       #ifdef PATHNAME_RISCOS
  2629.       # Device:
  2630.       { var reg1 object device = ThePathname(pathname)->pathname_device;
  2631.         if (!(nullp(device))) # NIL -> kein String
  2632.           { pushSTACK(O(doppelpunkt_string)); # ":"
  2633.             pushSTACK(device); # Device auf den Stack
  2634.             pushSTACK(O(punkt_string)); # "."
  2635.             stringcount += 3; # und mitzählen
  2636.       }   }
  2637.       #endif
  2638.       # Directory:
  2639.       { var reg2 object directory = ThePathname(pathname)->pathname_directory;
  2640.         #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  2641.         # evtl. Doppelpunkt:
  2642.         if (!(stringcount == 0)) # nur falls schon was auf dem Stack
  2643.           { pushSTACK(O(doppelpunkt_string)); stringcount++; } # ":" auf den Stack
  2644.         #endif
  2645.         # Ist das erste subdir = :ABSOLUTE oder = :RELATIVE ?
  2646.         if (eq(Car(directory),S(Kabsolute)))
  2647.           #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  2648.           { pushSTACK(O(backslash_string)); stringcount++; } # "\\" auf den Stack
  2649.           #endif
  2650.           #ifdef PATHNAME_AMIGAOS
  2651.           { pushSTACK(O(doppelpunkt_string)); stringcount++; } # ":" auf den Stack
  2652.           #endif
  2653.           #ifdef PATHNAME_UNIX
  2654.           { pushSTACK(O(slash_string)); stringcount++; } # "/" auf den Stack
  2655.           #endif
  2656.           #ifdef PATHNAME_RISCOS
  2657.           { directory = Cdr(directory); # übergehen
  2658.            {var reg1 object firstdir = Car(directory);
  2659.             if (eq(firstdir,S(Kroot)))
  2660.               { pushSTACK(O(root_string)); stringcount++; } # "$." auf den Stack
  2661.             elif (eq(firstdir,S(Khome)))
  2662.               { pushSTACK(O(home_string)); stringcount++; } # "&." auf den Stack
  2663.             elif (eq(firstdir,S(Kcurrent)))
  2664.               { pushSTACK(O(current_string)); stringcount++; } # "@." auf den Stack
  2665.             elif (eq(firstdir,S(Klibrary)))
  2666.               { pushSTACK(O(library_string)); stringcount++; } # "%." auf den Stack
  2667.             elif (eq(firstdir,S(Kprevious)))
  2668.               { pushSTACK(O(previous_string)); stringcount++; } # "\\." auf den Stack
  2669.             else
  2670.               { NOTREACHED }
  2671.           }}
  2672.           #endif
  2673.         directory = Cdr(directory); # übergehen
  2674.         # weitere subdirs auf den Stack:
  2675.         while (consp(directory))
  2676.           { stringcount += subdir_namestring_parts(directory);
  2677.             #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  2678.             pushSTACK(O(backslash_string)); stringcount++; # "\\" auf den Stack
  2679.             #endif
  2680.             #if defined(PATHNAME_UNIX) || defined(PATHNAME_AMIGAOS)
  2681.             pushSTACK(O(slash_string)); stringcount++; # "/" auf den Stack
  2682.             #endif
  2683.             #ifdef PATHNAME_RISCOS
  2684.             pushSTACK(O(punkt_string)); stringcount++; # "." auf den Stack
  2685.             #endif
  2686.             directory = Cdr(directory);
  2687.           }
  2688.       }
  2689.       return stringcount;
  2690.     }
  2691.  
  2692. # UP: Legt Teilstrings für STRING_CONCAT auf den STACK, die zusammen den
  2693. # String für Name und Typ des Pathname ergeben.
  2694. # nametype_namestring_parts(name,type,version)
  2695. # > name, type, evtl. version: Komponenten des Pathname
  2696. # < ergebnis: Anzahl der auf den Stack gelegten Strings
  2697. # kann GC auslösen
  2698. # verändert STACK
  2699.   #if HAS_VERSION
  2700.   local uintC nametype_namestring_parts (object name, object type, object version);
  2701.   local uintC nametype_namestring_parts PARM3(name,type,version,
  2702.     var reg2 object name,
  2703.     var reg1 object type,
  2704.     var reg4 object version)
  2705.   #else
  2706.   local uintC nametype_namestring_parts_ (object name, object type);
  2707.   local uintC nametype_namestring_parts_ PARM2(name,type,
  2708.     var reg2 object name,
  2709.     var reg1 object type)
  2710.   #define nametype_namestring_parts(n,t,v)  nametype_namestring_parts_(n,t)
  2711.   #endif
  2712.     { var reg3 uintC stringcount = 0;
  2713.       # Name:
  2714.       if (!nullp(name)) # name=NIL -> nicht ausgeben
  2715.         {
  2716.           #if defined(PATHNAME_MSDOS)
  2717.           if (eq(name,S(Kwild))) { name = O(wild_string); } # :WILD -> String "*"
  2718.           #endif
  2719.           pushSTACK(name); # Name auf den Stack
  2720.           stringcount++; # und mitzählen
  2721.         }
  2722.       # Typ:
  2723.       if (!nullp(type)) # type=NIL -> nicht ausgeben
  2724.         { pushSTACK(O(punkt_string)); # "." auf den Stack
  2725.           stringcount++; # und mitzählen
  2726.           #if defined(PATHNAME_MSDOS)
  2727.           if (eq(type,S(Kwild))) { type = O(wild_string); } # :WILD -> String "*"
  2728.           #endif
  2729.           pushSTACK(type); # Typ auf den Stack
  2730.           stringcount++; # und mitzählen
  2731.         }
  2732.       #if HAS_VERSION
  2733.       if (!nullp(version)) # version=NIL -> nicht ausgeben
  2734.         { pushSTACK(O(strichpunkt_string)); # ";" auf den Stack
  2735.           stringcount++; # und mitzählen
  2736.           if (eq(version,S(Knewest)))
  2737.             { pushSTACK(O(zero_string)); } # :NEWEST -> String "0"
  2738.             else
  2739.           # Version (Integer >0) in String umwandeln: (sys::decimal-string version)
  2740.           { pushSTACK(version);
  2741.             C_decimal_string(); # == funcall(L(decimal_string),1);
  2742.             pushSTACK(value1);
  2743.           }
  2744.           stringcount++; # und mitzählen
  2745.         }
  2746.       #endif
  2747.       return stringcount;
  2748.     }
  2749.  
  2750. # UP: Legt Teilstrings für STRING_CONCAT auf den STACK, die zusammen den
  2751. # String für Name und Typ des Pathname ergeben.
  2752. # file_namestring_parts(pathname)
  2753. # > pathname: nicht-Logical Pathname
  2754. # < ergebnis: Anzahl der auf den Stack gelegten Strings
  2755. # kann GC auslösen
  2756. # verändert STACK
  2757.   local uintC file_namestring_parts (object pathname);
  2758.   local uintC file_namestring_parts(pathname)
  2759.     var reg1 object pathname;
  2760.     { return nametype_namestring_parts(ThePathname(pathname)->pathname_name,
  2761.                                        ThePathname(pathname)->pathname_type,
  2762.                                        ThePathname(pathname)->pathname_version);
  2763.     }
  2764.  
  2765. # UP: Wandelt Pathname in String um.
  2766. # whole_namestring(pathname)
  2767. # > pathname: nicht-Logical Pathname
  2768. # < ergebnis: Simple-String
  2769. # kann GC auslösen
  2770.   local object whole_namestring (object pathname);
  2771.   local object whole_namestring(pathname)
  2772.     var reg1 object pathname;
  2773.     { var reg2 uintC stringcount;
  2774.       stringcount = host_namestring_parts(pathname); # Strings für den Host
  2775.       stringcount += directory_namestring_parts(pathname); # Strings fürs Directory
  2776.       stringcount += file_namestring_parts(pathname); # Strings für den Filename
  2777.       subr_self = L(namestring); # ("aktuelles" SUBR für Fehlermeldung)
  2778.       return string_concat(stringcount); # zusammenhängen
  2779.     }
  2780.  
  2781. LISPFUNN(file_namestring,1)
  2782. # (FILE-NAMESTRING pathname), CLTL S. 417
  2783.   { var reg1 object pathname = coerce_pathname(popSTACK());
  2784.     var reg2 uintC stringcount = file_namestring_parts(pathname); # Strings für den Filename
  2785.     value1 = string_concat(stringcount); mv_count=1; # zusammenhängen
  2786.   }
  2787.  
  2788. # UP: Liefert den String zum Directory eines Pathname.
  2789. # directory_namestring(pathname)
  2790. # > pathname: nicht-Logical Pathname
  2791. # > subr_self: Aufrufer (ein SUBR)
  2792. # < ergebnis: Simple-String
  2793. # kann GC auslösen
  2794.   local object directory_namestring (object pathname);
  2795.   local object directory_namestring(pathname)
  2796.     var reg1 object pathname;
  2797.     { var reg2 uintC stringcount =
  2798.         directory_namestring_parts(pathname); # Strings fürs Directory
  2799.       return string_concat(stringcount); # zusammenhängen
  2800.     }
  2801.  
  2802. LISPFUNN(directory_namestring,1)
  2803. # (DIRECTORY-NAMESTRING pathname), CLTL S. 417
  2804.   { var reg1 object pathname = coerce_pathname(popSTACK());
  2805.     value1 = directory_namestring(pathname); mv_count=1;
  2806.   }
  2807.  
  2808. LISPFUNN(host_namestring,1)
  2809. # (HOST-NAMESTRING pathname), CLTL S. 417
  2810.   { var reg1 object pathname = coerce_pathname(popSTACK());
  2811.     #if HAS_HOST
  2812.     var reg2 uintC stringcount = host_namestring_parts(pathname); # Strings für den Host
  2813.     value1 = string_concat(stringcount); # zusammenhängen
  2814.     #else
  2815.     value1 = O(leer_string); # "" als Wert
  2816.     #endif
  2817.     mv_count=1;
  2818.   }
  2819.  
  2820. #if HAS_VERSION || defined(LOGICAL_PATHNAMES)
  2821. # UP: Überprüft ein optionales VERSION-Argument.
  2822. # test_optional_version(def);
  2823. # > STACK_0: VERSION-Argument
  2824. # > def: Defaultwert dafür
  2825. # > subr_self: Aufrufer (ein SUBR)
  2826. # < ergebnis: gültige Version-Komponente
  2827.   local object test_optional_version (object def);
  2828.   local object test_optional_version(def)
  2829.     var reg2 object def;
  2830.     { var reg1 object version = STACK_0;
  2831.       if (eq(version,unbound)) { return def; } # nicht angegeben -> Default
  2832.       elif (nullp(version)) {} # NIL ist OK
  2833.       elif (eq(version,S(Kwild))) {} # :WILD ist OK
  2834.       elif (eq(version,S(Knewest))) {} # :NEWEST ist OK
  2835.       elif (posfixnump(version) && !eq(version,Fixnum_0)) {} # Fixnum >0 ist OK
  2836.       elif (pathnamep(version)) # Pathname -> dessen Version
  2837.         { STACK_0 = xpathname_version(FALSE,version); }
  2838.       #ifdef LOGICAL_PATHNAMES
  2839.       elif (logpathnamep(version)) # Logical Pathname -> dessen Version
  2840.         { STACK_0 = TheLogpathname(version)->pathname_version; }
  2841.       #endif
  2842.       else # Keiner der gewünschten Fälle -> Fehler:
  2843.         { pushSTACK(version); # Wert für Slot DATUM von TYPE-ERROR
  2844.           pushSTACK(O(type_version)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  2845.           pushSTACK(version);
  2846.           pushSTACK(TheSubr(subr_self)->name);
  2847.           //: DEUTSCH "~: :VERSION-Argument muß NIL oder ein Fixnum >0 oder :WILD oder :NEWEST sein, nicht ~"
  2848.           //: ENGLISH "~: :VERSION-argument should be NIL or a positive fixnum or :WILD or :NEWEST, not ~"
  2849.           //: FRANCAIS "~ : L'argument pour :VERSION doit être NIL, un petit nombre entier positif, :WILD ou :NEWEST mais non ~"
  2850.           fehler(type_error, GETTEXT("~: :VERSION-argument should be NIL or a positive fixnum or :WILD or :NEWEST, not ~"));
  2851.         }
  2852.       return version;
  2853.     }
  2854. #else
  2855. # UP: Überprüft ein optionales VERSION-Argument.
  2856. # test_optional_version();
  2857. # > STACK_0: VERSION-Argument
  2858. # > subr_self: Aufrufer (ein SUBR)
  2859.   #define test_optional_version(def)  test_optional_version_()
  2860.   local void test_optional_version_ (void);
  2861.   local void test_optional_version_()
  2862.     { var reg1 object version = STACK_0;
  2863.       if (eq(version,unbound) # nicht angegeben?
  2864.           || nullp(version)         # oder NIL ?
  2865.           || eq(version,S(Kwild))   # oder :WILD ?
  2866.           || eq(version,S(Knewest)) # oder :NEWEST ?
  2867.          )
  2868.         { return; } # ja -> OK
  2869.         else
  2870.         { pushSTACK(version); # Wert für Slot DATUM von TYPE-ERROR
  2871.           pushSTACK(O(type_version)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  2872.           pushSTACK(version);
  2873.           pushSTACK(TheSubr(subr_self)->name);
  2874.           //: DEUTSCH "~: :VERSION-Argument muß NIL oder :WILD oder :NEWEST sein, nicht ~"
  2875.           //: ENGLISH "~: :VERSION-argument should be NIL or :WILD or :NEWEST, not ~"
  2876.           //: FRANCAIS "~ : L'argument pour :VERSION doit être NIL, :WILD ou :NEWEST mais non ~"
  2877.           fehler(type_error, GETTEXT("~: :VERSION-argument should be NIL or :WILD or :NEWEST, not ~"));
  2878.     }   }
  2879. #endif
  2880.  
  2881. #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  2882.  
  2883. # Das Betriebssystem verwaltet ein Default-Drive.
  2884. # Das Betriebssystem verwaltet auf jedem Drive ein Default-Directory. Dieses
  2885. # kann sich allerdings ändern, wenn eine andere Diskette eingelegt wird.
  2886.  
  2887. # Es wird ein Default-Drive geführt: DEFAULT_DRIVE = O(default_drive).
  2888.  
  2889. # Die Variable *DEFAULT-PATHNAME-DEFAULTS* enthält (als Pathname) den
  2890. # Defaultwert für jede MERGE-Operation. Dies ist derjenige, den das System
  2891. # in vom Benutzer eingegebene Pathnames "hineininterpretiert".
  2892. # Er wird auf dem neuesten Stand des DEFAULT_DRIVE gehalten: bei der
  2893. # Initialisierung das aktuelle Device (im Sinne von DOS), bei der
  2894. # Änderung von DEFAULT_DRIVE mittels CD.
  2895.  
  2896. #endif # PATHNAME_MSDOS || PATHNAME_OS2
  2897.  
  2898. #if defined(PATHNAME_UNIX) || defined(PATHNAME_AMIGAOS)
  2899.  
  2900. # Die Variable *DEFAULT-PATHNAME-DEFAULTS* enthält (als Pathname) den
  2901. # Defaultwert für jede MERGE-Operation. Dies ist derjenige, den das System
  2902. # in vom Benutzer eingegebene Pathnames "hineininterpretiert".
  2903.  
  2904. #endif
  2905.  
  2906. #if defined(UNIX) || defined(WIN32_UNIX)
  2907.  
  2908. # Das Betriebssystem verwaltet ein Default-Directory ("working directory")
  2909. # für diesen Prozeß. Es kann mit chdir verändert und mit getwd abgefragt
  2910. # werden. Siehe CHDIR(2) und GETWD(3).
  2911.  
  2912. #endif
  2913.  
  2914. #ifdef AMIGAOS
  2915.  
  2916. # Das Betriebssystem verwaltet ein Default-Directory ("current directory")
  2917. # für diesen Prozeß. Es kann mit CurrentDir verändert und mit einer
  2918. # Kombination aus Examine und ParentDir abgefragt werden.
  2919.  
  2920. #endif
  2921.  
  2922. # UP: Neuberechnung von *DEFAULT-PATHNAME-DEFAULTS*
  2923. #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  2924. # aus DEFAULT_DRIVE
  2925. #endif
  2926. # recalc_defaults_pathname();
  2927. # < ergebnis: Wert von *DEFAULT-PATHNAME-DEFAULTS*, ein Pathname
  2928. # kann GC auslösen
  2929.   local object recalc_defaults_pathname (void);
  2930.   local object recalc_defaults_pathname()
  2931.     {
  2932.       #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  2933.       # (MAKE-PATHNAME :DEVICE default-drive) ausführen:
  2934.       pushSTACK(S(Kdevice)); pushSTACK(O(default_drive));
  2935.       funcall(L(make_pathname),2);
  2936.       #endif
  2937.       #if defined(PATHNAME_UNIX) || defined(PATHNAME_AMIGAOS) || defined(PATHNAME_RISCOS)
  2938.       # (MAKE-PATHNAME) ausführen:
  2939.       funcall(L(make_pathname),0);
  2940.       #endif
  2941.       # und *DEFAULT-PATHNAME-DEFAULTS* zuweisen:
  2942.       set_Symbol_value(S(default_pathname_defaults),value1);
  2943.       return value1;
  2944.     }
  2945.  
  2946. # UP: Liefert den Default-Pathname.
  2947. # defaults_pathname()
  2948. # < ergebnis: Wert von *DEFAULT-PATHNAME-DEFAULTS*, ein Pathname
  2949. # kann GC auslösen
  2950.   local object defaults_pathname (void);
  2951.   local object defaults_pathname()
  2952.     { var reg1 object pathname = Symbol_value(S(default_pathname_defaults)); # Wert von *DEFAULT-PATHNAME-DEFAULTS*
  2953.       if (pathnamep(pathname))
  2954.         # ist Pathname -> OK
  2955.         { return pathname; }
  2956.         else
  2957.         # sonst Warnung:
  2958.         { pushSTACK(subr_self); # subr_self retten (für spätere Fehlermeldungen)
  2959.           # (WARN "Der Wert von ~S war kein Pathname. ~:*~S wird zurückgesetzt." ...)
  2960.           pushSTACK(OL(defaults_warn_string));
  2961.           pushSTACK(S(default_pathname_defaults));
  2962.           funcall(S(warn),2);
  2963.           # und neuberechnen:
  2964.           pathname = recalc_defaults_pathname();
  2965.           subr_self = popSTACK();
  2966.           return pathname;
  2967.     }   }
  2968.  
  2969. LISPFUN(merge_pathnames,1,2,norest,key,1, (kw(wild)))
  2970. # (MERGE-PATHNAMES pathname [defaults [default-version]] [:wild]), CLTL S. 415
  2971. # (defun merge-pathnames (pathname &optional (defaults *default-pathname-defaults*) default-version)
  2972. #   (setq pathname (pathname pathname))
  2973. #   (setq defaults (pathname defaults))
  2974. #   (multiple-value-call #'make-pathname
  2975. #if HAS_HOST
  2976. #     (if (or (equal (pathname-host pathname) (pathname-host defaults))
  2977. #             (null (pathname-host pathname))
  2978. #         )
  2979. #       (values
  2980. #         :host (or (pathname-host pathname) (pathname-host defaults))
  2981. #endif
  2982. #if HAS_DEVICE
  2983. #     (if (or (equal (pathname-device pathname) (pathname-device defaults))
  2984. #             (null (pathname-device pathname))
  2985. #         )
  2986. #       (values
  2987. #         :device (or (pathname-device pathname) (pathname-device defaults))
  2988. #endif
  2989. #         :directory
  2990. #           (let ((pathname-dir (pathname-directory pathname))
  2991. #                 (defaults-dir (pathname-directory defaults)))
  2992. #             (if (eq (car pathname-dir) ':RELATIVE)
  2993. #               (cond ((null (cdr pathname-dir)) defaults-dir)
  2994. #                     ((not (eq (car defaults-dir) ':RELATIVE))
  2995. #                      (append defaults-dir (cdr pathname-dir))
  2996. #                     )
  2997. #                     (t pathname-dir)
  2998. #               )
  2999. #               pathname-dir
  3000. #           ) )
  3001. #       )
  3002. #       (values
  3003. #if HAS_HOST
  3004. #         :host (pathname-host pathname)
  3005. #endif
  3006. #if HAS_DEVICE
  3007. #         :device (pathname-device pathname)
  3008. #endif
  3009. #         :directory (pathname-directory pathname)
  3010. #     ) )
  3011. #     :name (or (pathname-name pathname) (pathname-name defaults))
  3012. #     :type (or (pathname-type pathname) (pathname-type defaults))
  3013. # ) )
  3014. # Ist das :WILD-Argument angegeben, werden statt fehlenden Komponenten
  3015. # :WILD-Komponenten ersetzt.
  3016.   { var reg10 boolean wildp = !(eq(STACK_0,unbound) || nullp(STACK_0));
  3017.     skipSTACK(1);
  3018.     # default-version überprüfen:
  3019.     #if HAS_VERSION || defined(LOGICAL_PATHNAMES)
  3020.     {var reg9 object v = test_optional_version(S(Knewest)); # Default ist :NEWEST
  3021.      STACK_0 = STACK_1; STACK_1 = STACK_2; STACK_2 = v;
  3022.     }# Stackaufbau: default-version, pathname, defaults.
  3023.     #else
  3024.      test_optional_version(S(Knewest)); skipSTACK(1);
  3025.      # Stackaufbau: pathname, defaults.
  3026.     #endif
  3027.     # pathname und defaults überprüfen:
  3028.     # defaults zu einem Pathname machen:
  3029.     STACK_0 = test_default_pathname(STACK_0);
  3030.     # pathname zu einem Pathname machen:
  3031.     #ifdef LOGICAL_PATHNAMES
  3032.     if (logpathnamep(STACK_0))
  3033.       { if (!xpathnamep(STACK_1))
  3034.           { pushSTACK(subr_self); # subr_self retten (für spätere Fehlermeldungen)
  3035.             # Das Ergebnis von (PARSE-NAMESTRING obj nil empty-logical-pathname)
  3036.             # ist garantiert ein logischer Pathname.
  3037.             pushSTACK(STACK_(1+1)); pushSTACK(NIL); pushSTACK(O(empty_logical_pathname));
  3038.             funcall(L(parse_namestring),3);
  3039.             subr_self = popSTACK();
  3040.             STACK_1 = value1;
  3041.       }   }
  3042.       else
  3043.     #endif
  3044.       { STACK_1 = coerce_xpathname(STACK_1); }
  3045.     #ifdef LOGICAL_PATHNAMES
  3046.     if (logpathnamep(STACK_1) && logpathnamep(STACK_0))
  3047.       # MERGE-PATHNAMES für Logical Pathnames
  3048.       { var reg6 object new = allocate_logpathname(); # neuen Pathname holen
  3049.         var reg8 object d = popSTACK(); # defaults
  3050.         var reg7 object p = popSTACK(); # pathname
  3051.         # Hosts matchen:
  3052.         { var reg1 object p_host = TheLogpathname(p)->pathname_host;
  3053.           var reg2 object d_host = TheLogpathname(d)->pathname_host;
  3054.           TheLogpathname(new)->pathname_host = p_host; # erstmal new-host := pathname-host
  3055.           if (equal(p_host,d_host)) goto lmatch_directories;
  3056.           if (wildp ? FALSE : nullp(p_host))
  3057.             { # pathname-host nicht angegeben, aber defaults-host angegeben:
  3058.               TheLogpathname(new)->pathname_host = d_host; # new-host := defaults-host
  3059.               goto lmatch_directories;
  3060.         }   }
  3061.         # Directories nicht matchen:
  3062.         { # new-directory := pathname-directory :
  3063.           TheLogpathname(new)->pathname_directory = TheLogpathname(p)->pathname_directory;
  3064.         }
  3065.         goto ldirectories_OK;
  3066.         lmatch_directories:
  3067.         # Directories matchen:
  3068.         { var reg2 object p_directory = TheLogpathname(p)->pathname_directory; # pathname-directory
  3069.           var reg3 object d_directory = TheLogpathname(d)->pathname_directory; # defaults-directory
  3070.          {var reg4 object new_subdirs = p_directory;
  3071.       # Fängt pathname-subdirs mit :RELATIVE an?
  3072.           if (!wildp && eq(Car(p_directory),S(Krelative)))
  3073.             # ja.
  3074.             { # Endet pathname-subdirs danach?
  3075.               if (matomp(Cdr(p_directory)))
  3076.                 # ja -> verwende defaults-subdirs:
  3077.                 { new_subdirs = d_directory; }
  3078.                 else
  3079.                 # nein.
  3080.                 { # Fängt defaults-subdirs mit :RELATIVE an?
  3081.                   if (eq(Car(d_directory),S(Krelative)))
  3082.                     # ja -> Ersetzen von :RELATIVE in pathname-subdirs
  3083.                     # durch das gesamte defaults-subdirs ist nicht sinnvoll
  3084.                     # (da nicht klar ist, auf was das dabei entstehende
  3085.                     # Default-Directory sich beziehen soll). Daher nichts tun:
  3086.                     {}
  3087.                     else
  3088.                     # nein -> Um :RELATIVE aufzulösen: ersetze :RELATIVE
  3089.                     # in pathname-subdirs durch defaults-subdirs, d.h.
  3090.                     # bilde (append defaults-subdirs (cdr pathname-subdirs)) =
  3091.                     # (nreconc (reverse defaults-subdirs) (cdr pathname-subdirs)) :
  3092.                     { pushSTACK(p); pushSTACK(d); pushSTACK(new);
  3093.                       pushSTACK(Cdr(p_directory));
  3094.                       {var reg1 object temp = reverse(d_directory);
  3095.                        new_subdirs = nreconc(temp,popSTACK());
  3096.                       }
  3097.                       new = popSTACK(); d = popSTACK(); p = popSTACK();
  3098.                     }
  3099.             }   }
  3100.           TheLogpathname(new)->pathname_directory = new_subdirs; # new-directory := new-subdirs
  3101.         }}
  3102.         ldirectories_OK:
  3103.         # Nun sind die Directories OK.
  3104.         # Name matchen:
  3105.         # Verwende pathname-name, falls angegeben, und defaults-name sonst.
  3106.         { var reg1 object p_name = TheLogpathname(p)->pathname_name;
  3107.           TheLogpathname(new)->pathname_name =
  3108.             (!(wildp ? eq(p_name,S(Kwild)) : nullp(p_name))
  3109.              ? p_name
  3110.              : TheLogpathname(d)->pathname_name
  3111.             );
  3112.         }
  3113.         # Typ matchen:
  3114.         # Verwende pathname-type, falls angegeben, und defaults-type sonst.
  3115.         { var reg1 object p_type = TheLogpathname(p)->pathname_type;
  3116.           TheLogpathname(new)->pathname_type =
  3117.             (!(wildp ? eq(p_type,S(Kwild)) : nullp(p_type))
  3118.              ? p_type
  3119.              : TheLogpathname(d)->pathname_type
  3120.             );
  3121.         }
  3122.         # Version matchen:
  3123.         # Verwende pathname-version, falls angegeben, und default-version sonst.
  3124.         { var reg1 object p_version = TheLogpathname(p)->pathname_version;
  3125.           TheLogpathname(new)->pathname_version =
  3126.             (!(wildp ? eq(p_version,S(Kwild)) : nullp(p_version))
  3127.              ? p_version
  3128.              : STACK_0
  3129.             );
  3130.           skipSTACK(1);
  3131.         }
  3132.         # new als Wert:
  3133.         value1 = new; mv_count=1;
  3134.         return;
  3135.       }
  3136.     # nicht beides logische Pathnames -> erst in normale Pathnames umwandeln:
  3137.     STACK_1 = coerce_pathname(STACK_1);
  3138.     STACK_0 = coerce_pathname(STACK_0);
  3139.     #endif
  3140.    {var reg6 object new = allocate_pathname(); # neuen Pathname holen
  3141.     var reg8 object d = popSTACK(); # defaults
  3142.     var reg7 object p = popSTACK(); # pathname
  3143.     #if HAS_HOST
  3144.     # Hosts matchen:
  3145.     { var reg1 object p_host = ThePathname(p)->pathname_host;
  3146.       var reg2 object d_host = ThePathname(d)->pathname_host;
  3147.       ThePathname(new)->pathname_host = p_host; # erstmal new-host := pathname-host
  3148.       # beide Hosts gleich -> Devices matchen:
  3149.       if (equal(p_host,d_host)) goto match_devices;
  3150.       if (wildp ? FALSE : nullp(p_host))
  3151.         { # pathname-host nicht angegeben, aber defaults-host angegeben:
  3152.           ThePathname(new)->pathname_host = d_host; # new-host := defaults-host
  3153.           goto match_devices;
  3154.         }
  3155.       goto notmatch_devices;
  3156.     }
  3157.     #endif
  3158.     match_devices:
  3159.     #if HAS_DEVICE
  3160.     # Devices matchen:
  3161.     { var reg1 object p_device = ThePathname(p)->pathname_device;
  3162.       var reg2 object d_device = ThePathname(d)->pathname_device;
  3163.       ThePathname(new)->pathname_device = p_device; # erstmal new-device := pathname-device
  3164.       # beide Devices gleich -> Directories matchen:
  3165.       if (equal(p_device,d_device)) goto match_directories;
  3166.       if (wildp ? eq(p_device,S(Kwild)) : nullp(p_device))
  3167.         { # pathname-device nicht angegeben, aber defaults-device angegeben:
  3168.           ThePathname(new)->pathname_device = d_device; # new-device := defaults-device
  3169.           goto match_directories;
  3170.         }
  3171.       goto notmatch_directories;
  3172.     }
  3173.     #endif
  3174.     # Directories matchen:
  3175.     match_directories:
  3176.     { var reg2 object p_directory = ThePathname(p)->pathname_directory; # pathname-directory
  3177.       var reg3 object d_directory = ThePathname(d)->pathname_directory; # defaults-directory
  3178.       var reg4 object new_subdirs = p_directory;
  3179.       # Fängt pathname-subdirs mit :RELATIVE an?
  3180.       if (!wildp && eq(Car(p_directory),S(Krelative)))
  3181.         # ja.
  3182.         { # Endet pathname-subdirs danach?
  3183.           if (matomp(Cdr(p_directory)))
  3184.             # ja -> verwende defaults-subdirs:
  3185.             { new_subdirs = d_directory; }
  3186.             else
  3187.             # nein.
  3188.             { # Fängt defaults-subdirs mit :RELATIVE an?
  3189.               if (eq(Car(d_directory),S(Krelative)))
  3190.                 # ja -> Ersetzen von :RELATIVE in pathname-subdirs
  3191.                 # durch das gesamte defaults-subdirs ist nicht sinnvoll
  3192.                 # (da nicht klar ist, auf was das dabei entstehende
  3193.                 # Default-Directory sich beziehen soll). Daher nichts tun:
  3194.                 {}
  3195.                 else
  3196.                 # nein -> Um :RELATIVE aufzulösen: ersetze :RELATIVE
  3197.                 # in pathname-subdirs durch defaults-subdirs, d.h.
  3198.                 # bilde (append defaults-subdirs (cdr pathname-subdirs)) =
  3199.                 # (nreconc (reverse defaults-subdirs) (cdr pathname-subdirs)) :
  3200.                 { pushSTACK(p); pushSTACK(d); pushSTACK(new);
  3201.                   pushSTACK(Cdr(p_directory));
  3202.                   {var reg1 object temp = reverse(d_directory);
  3203.                    new_subdirs = nreconc(temp,popSTACK());
  3204.                   }
  3205.                   new = popSTACK(); d = popSTACK(); p = popSTACK();
  3206.                 }
  3207.         }   }
  3208.       ThePathname(new)->pathname_directory = new_subdirs; # new-directory := new-subdirs
  3209.     }
  3210.     goto directories_OK;
  3211.     # Devices nicht matchen:
  3212.     notmatch_devices:
  3213.     #if HAS_DEVICE
  3214.     { # new-device := pathname-device :
  3215.       ThePathname(new)->pathname_device = ThePathname(p)->pathname_device;
  3216.     }
  3217.     #endif
  3218.     # Directories nicht matchen:
  3219.     notmatch_directories:
  3220.     { # new-directory := pathname-directory :
  3221.       ThePathname(new)->pathname_directory = ThePathname(p)->pathname_directory;
  3222.     }
  3223.     directories_OK:
  3224.     # Nun sind die Directories OK.
  3225.     # Name matchen:
  3226.     # Verwende pathname-name, falls angegeben, und defaults-name sonst.
  3227.     { var reg1 object p_name = ThePathname(p)->pathname_name;
  3228.       ThePathname(new)->pathname_name =
  3229.         (!(wildp ?
  3230.            #ifdef PATHNAME_EXT83
  3231.            eq(p_name,S(Kwild))
  3232.            #else # PATHNAME_NOEXT || PATHNAME_RISCOS
  3233.            equal(p_name,O(wild_string))
  3234.            #endif
  3235.            : nullp(p_name)
  3236.           )
  3237.          ? p_name
  3238.          : ThePathname(d)->pathname_name
  3239.         );
  3240.     }
  3241.     # Typ matchen:
  3242.     # Verwende pathname-type, falls angegeben, und defaults-type sonst.
  3243.     { var reg1 object p_type = ThePathname(p)->pathname_type;
  3244.       ThePathname(new)->pathname_type =
  3245.         (!(wildp ?
  3246.            #ifdef PATHNAME_EXT83
  3247.            eq(p_type,S(Kwild))
  3248.            #else # PATHNAME_NOEXT || PATHNAME_RISCOS
  3249.            equal(p_type,O(wild_string))
  3250.            #endif
  3251.            : nullp(p_type)
  3252.           )
  3253.          ? p_type
  3254.          : ThePathname(d)->pathname_type
  3255.         );
  3256.     }
  3257.     #if HAS_VERSION
  3258.     # Version matchen:
  3259.     # Verwende pathname-version, falls angegeben, und default-version sonst.
  3260.     { var reg1 object p_version = ThePathname(p)->pathname_version;
  3261.       ThePathname(new)->pathname_version =
  3262.         (!(wildp ? eq(p_version,S(Kwild)) : nullp(p_version))
  3263.          ? p_version
  3264.          : STACK_0
  3265.         );
  3266.     }
  3267.     #endif
  3268.     #if HAS_VERSION || defined(LOGICAL_PATHNAMES)
  3269.     skipSTACK(1);
  3270.     #endif
  3271.     # new als Wert:
  3272.     value1 = new; mv_count=1;
  3273.   }}
  3274.  
  3275. LISPFUN(enough_namestring,1,1,norest,nokey,0,NIL)
  3276. # (ENOUGH-NAMESTRING pathname [defaults]), CLTL S. 417
  3277. # (defun enough-namestring (pathname &optional (defaults *default-pathname-defaults*))
  3278. #   (setq pathname (pathname pathname))
  3279. #   (setq defaults (pathname defaults))
  3280. #   (namestring
  3281. #     (multiple-value-call #'make-pathname
  3282. #if HAS_HOST
  3283. #       (if (equal (pathname-host pathname) (pathname-host defaults))
  3284. #         (values
  3285. #           :host nil
  3286. #endif
  3287. #if HAS_DEVICE
  3288. #       (if (equal (pathname-device pathname) (pathname-device defaults))
  3289. #         (values
  3290. #           :device nil
  3291. #endif
  3292. #           :directory
  3293. #             (let ((pathname-dir (pathname-directory pathname))
  3294. #                   (defaults-dir (pathname-directory defaults)))
  3295. #               (if (equal pathname-dir defaults-dir)
  3296. #                 (list ':RELATIVE)
  3297. #                 (if (and (not (eq (car pathname-dir) ':RELATIVE))
  3298. #                          (not (eq (car defaults-dir) ':RELATIVE))
  3299. #                          (equal (subseq pathname-dir 0 (min (length pathname-dir) (length defaults-dir)))
  3300. #                                 defaults-dir
  3301. #                     )    )
  3302. #                   (cons ':RELATIVE (nthcdr (length defaults-dir) pathname-dir))
  3303. #                   pathname-dir
  3304. #             ) ) )
  3305. #         )
  3306. #         (values
  3307. #if HAS_HOST
  3308. #           :host (pathname-host pathname)
  3309. #endif
  3310. #if HAS_DEVICE
  3311. #           :device (pathname-device pathname)
  3312. #endif
  3313. #           :directory (pathname-directory pathname)
  3314. #       ) )
  3315. #       :name (if (equal (pathname-name pathname) (pathname-name defaults))
  3316. #               nil
  3317. #               (pathname-name pathname)
  3318. #             )
  3319. #       :type (if (equal (pathname-type pathname) (pathname-type defaults))
  3320. #               nil
  3321. #               (pathname-type pathname)
  3322. #             )
  3323. # ) ) )
  3324.   { # pathname und defaults überprüfen:
  3325.     # pathname zu einem Pathname machen:
  3326.     STACK_1 = coerce_pathname(STACK_1);
  3327.     # defaults zu einem Pathname machen:
  3328.     STACK_0 = coerce_pathname(test_default_pathname(STACK_0));
  3329.     # neuen Pathname holen:
  3330.    {var reg6 object new = allocate_pathname();
  3331.     pushSTACK(new);
  3332.     # Stackaufbau: pathname, defaults, new.
  3333.     #if HAS_HOST
  3334.     # Hosts vergleichen:
  3335.     { var reg7 object p_host = ThePathname(STACK_2)->pathname_host; # pathname-host
  3336.       var reg8 object d_host = ThePathname(STACK_1)->pathname_host; # defaults-host
  3337.       if (equal(p_host,d_host)) # beide Hosts gleich ?
  3338.         # ja.
  3339.         { ThePathname(new)->pathname_host = NIL; # new-host := NIL
  3340.     #endif
  3341.     #if HAS_DEVICE
  3342.     # Devices vergleichen:
  3343.     { var reg7 object p_device = ThePathname(STACK_2)->pathname_device; # pathname-device
  3344.       var reg8 object d_device = ThePathname(STACK_1)->pathname_device; # defaults-device
  3345.       if (equal(p_device,d_device)) # beide Devices gleich ?
  3346.         # ja.
  3347.         { ThePathname(new)->pathname_device = NIL; # new-device := NIL
  3348.     #endif
  3349.          {var reg3 object p_directory = ThePathname(STACK_2)->pathname_directory; # pathname-directory
  3350.           var reg4 object d_directory = ThePathname(STACK_1)->pathname_directory; # defaults-directory
  3351.           var reg5 object new_subdirs;
  3352.           # vergleiche pathname-subdirs und defaults-subdirs:
  3353.           if (equal(p_directory,d_directory))
  3354.             # gleich -> verwende (cons :RELATIVE nil) :
  3355.             { new_subdirs = NIL; goto insert_RELATIVE; }
  3356.             else
  3357.             { # Fängt weder pathname-subdirs noch defaults-subdirs
  3358.               # mit :RELATIVE an?
  3359.               if (   (!eq(Car(p_directory),S(Krelative)))
  3360.                   && (!eq(Car(d_directory),S(Krelative)))
  3361.                  )
  3362.                 # ja -> testen, ob defaults-subdirs ein Anfangsstück
  3363.                 # der Liste pathname-subdirs ist:
  3364.                 { var reg1 object Lp = p_directory;
  3365.                   var reg2 object Ld = d_directory;
  3366.                   # Ist Ld ein Anfangsstück von Lp ?
  3367.                   loop
  3368.                     { if (atomp(Ld)) # Ld zu Ende -> ja
  3369.                         { new_subdirs = Lp; goto insert_RELATIVE; }
  3370.                       if (atomp(Lp)) break; # Lp zu Ende -> nein
  3371.                       if (!equal(Car(Ld),Car(Lp))) # verschiedene Listenelemente?
  3372.                         break; # -> nein
  3373.                       Ld = Cdr(Ld); Lp = Cdr(Lp); # Listen weiterrücken
  3374.                     }
  3375.                 }
  3376.               new_subdirs = p_directory; # new-subdirs := pathname-subdirs
  3377.               goto subdirs_ok;
  3378.             }
  3379.           insert_RELATIVE:
  3380.           # new-subdirs := (cons :RELATIVE new-subdirs) :
  3381.           { pushSTACK(new_subdirs);
  3382.             new_subdirs = allocate_cons();
  3383.             Cdr(new_subdirs) = popSTACK(); Car(new_subdirs) = S(Krelative);
  3384.           }
  3385.           subdirs_ok: # new-subdirs ist die neue Subdir-Liste.
  3386.           # new-directory := new-subdirs :
  3387.           ThePathname(new=STACK_0)->pathname_directory = new_subdirs;
  3388.          }
  3389.     #if HAS_DEVICE
  3390.         }
  3391.         else
  3392.         # verschiedene Devices
  3393.         { # new-device := pathname-device :
  3394.           ThePathname(new)->pathname_device = p_device;
  3395.           # new-directory := pathname-directory :
  3396.           ThePathname(new)->pathname_directory = ThePathname(STACK_2)->pathname_directory;
  3397.         }
  3398.     }
  3399.     #endif
  3400.     #if HAS_HOST
  3401.         }
  3402.         else
  3403.         # verschiedene Hosts
  3404.         { # new-host := pathname-host :
  3405.           ThePathname(new)->pathname_host = p_host;
  3406.           #if HAS_DEVICE
  3407.           # new-device := pathname-device :
  3408.           ThePathname(new)->pathname_device = ThePathname(STACK_2)->pathname_device;
  3409.           #endif
  3410.           # new-directory := pathname-directory :
  3411.           ThePathname(new)->pathname_directory = ThePathname(STACK_2)->pathname_directory;
  3412.         }
  3413.     }
  3414.     #endif
  3415.     # name einfüllen:
  3416.     { var reg1 object p_name = ThePathname(STACK_2)->pathname_name; # pathname-name
  3417.       var reg2 object d_name = ThePathname(STACK_1)->pathname_name; # defaults-name
  3418.       ThePathname(new)->pathname_name = (equal(p_name,d_name) ? NIL : p_name);
  3419.     }
  3420.     # type einfüllen:
  3421.     { var reg1 object p_type = ThePathname(STACK_2)->pathname_type; # pathname-type
  3422.       var reg2 object d_type = ThePathname(STACK_1)->pathname_type; # defaults-type
  3423.       ThePathname(new)->pathname_type = (equal(p_type,d_type) ? NIL : p_type);
  3424.     }
  3425.     skipSTACK(3);
  3426.     # (namestring new) bilden:
  3427.     value1 = whole_namestring(new); mv_count=1;
  3428.   }}
  3429.  
  3430. #ifdef LOGICAL_PATHNAMES
  3431.  
  3432. # UP: Überprüft, ob object ein zulässiger Name ist:
  3433. # :WILD oder ein Simple-String aus gültigen Zeichen, keine adjazenten '*'.
  3434. # legal_logical_word(object)
  3435.   local boolean legal_logical_word (object obj);
  3436.   local boolean legal_logical_word(obj)
  3437.     var reg5 object obj;
  3438.     { if (eq(obj,S(Kwild))) { return TRUE; }
  3439.       if (!simple_string_p(obj)) { return FALSE; }
  3440.      {var reg3 uintL len = TheSstring(obj)->length;
  3441.       if (len==0) { return FALSE; } # leeres Word ist verboten
  3442.       {var reg2 uintB* charptr = &TheSstring(obj)->data[0];
  3443.        var reg4 boolean last_was_star = FALSE;
  3444.        dotimespL(len,len,
  3445.          { var reg1 uintB ch = *charptr++;
  3446.            if (!(legal_logical_word_char(ch) || (ch=='*'))) { return FALSE; }
  3447.            if (ch=='*')
  3448.              { if (last_was_star) return FALSE; # adjazente '*' sind verboten
  3449.                last_was_star = TRUE;
  3450.              }
  3451.              else
  3452.              { last_was_star = FALSE; }
  3453.          });
  3454.        return TRUE;
  3455.     }}}
  3456.  
  3457. #endif
  3458.  
  3459. #ifdef PATHNAME_EXT83
  3460.  
  3461. # UP: Überprüft, ob object ein zulässiger Name oder Typ ist: :WILD oder
  3462. # ein Simple-String mit max. stdlen Zeichen, alle alphabetisch und Up-case.
  3463. # legal_name_or_type(object,stdlen)
  3464.   local boolean legal_name_or_type (object obj, uintL stdlen);
  3465.   local boolean legal_name_or_type(obj,stdlen)
  3466.     var reg3 object obj;
  3467.     var reg4 uintL stdlen;
  3468.     { if (eq(obj,S(Kwild))) { return TRUE; } # :WILD ist OK
  3469.       if (!simple_string_p(obj)) { return FALSE; } # sonst: Simple-String ?
  3470.      {var reg2 uintL len = TheSstring(obj)->length;
  3471.       #ifndef EMUNIX_PORTABEL
  3472.       if (!(len <= stdlen)) { return FALSE; } # und Länge <=stdlen ?
  3473.       #endif
  3474.       # Jedes einzelne Zeichen überprüfen:
  3475.       {var reg1 uintB* ptr = &TheSstring(obj)->data[0];
  3476.        dotimesL(len,len,
  3477.          { var reg1 uintB ch = *ptr++;
  3478.            if (!(legal_namechar(ch) # zulässiges Zeichen ?
  3479.                  && (up_case(ch)==ch) # und Großbuchstabe ?
  3480.               ) )
  3481.              { return FALSE; }
  3482.          });
  3483.       }
  3484.       return TRUE;
  3485.     }}
  3486.  
  3487. # UP: Überprüft, ob object ein zulässiger Name ist: :WILD oder
  3488. # ein Simple-String mit max. 8 Zeichen, alle alphabetisch und Up-case.
  3489. # legal_name(object)
  3490.   #define legal_name(obj)  legal_name_or_type(obj,8)
  3491.  
  3492. # UP: Überprüft, ob object ein zulässiger Typ ist: :WILD oder
  3493. # ein Simple-String mit max. 3 Zeichen, alle alphabetisch und Up-case.
  3494. # legal_type(object)
  3495.   #define legal_type(obj)  legal_name_or_type(obj,3)
  3496.  
  3497. #endif # PATHNAME_EXT83
  3498.  
  3499. #if defined(PATHNAME_NOEXT) || defined(PATHNAME_RISCOS)
  3500.  
  3501. # UP: Überprüft, ob object ein zulässiger Name ist:
  3502. # ein Simple-String aus gültigen Zeichen
  3503. # legal_name(object)
  3504.   local boolean legal_name (object obj);
  3505.   local boolean legal_name(obj)
  3506.     var reg3 object obj;
  3507.     { if (!simple_string_p(obj)) { return FALSE; }
  3508.      {var reg2 uintL len = TheSstring(obj)->length;
  3509.       var reg1 uintB* charptr = &TheSstring(obj)->data[0];
  3510.       dotimesL(len,len, { if (!legal_namechar(*charptr++)) { return FALSE; } } );
  3511.       return TRUE;
  3512.     }}
  3513.  
  3514. # UP: Überprüft, ob object ein zulässiger Name ist:
  3515. # ein Simple-String aus gültigen Zeichen, ohne '.'
  3516. # legal_type(object)
  3517.   local boolean legal_type (object obj);
  3518. #ifdef PATHNAME_NOEXT
  3519.   local boolean legal_type(obj)
  3520.     var reg4 object obj;
  3521.     { if (!simple_string_p(obj)) { return FALSE; }
  3522.      {var reg3 uintL len = TheSstring(obj)->length;
  3523.       var reg2 uintB* charptr = &TheSstring(obj)->data[0];
  3524.       dotimesL(len,len,
  3525.         { var reg1 uintB ch = *charptr++;
  3526.           if ((ch=='.') || (!legal_namechar(ch))) { return FALSE; }
  3527.         });
  3528.       return TRUE;
  3529.     }}
  3530. #endif
  3531. #ifdef PATHNAME_RISCOS
  3532.   #define legal_type(obj)  legal_name(obj)
  3533. #endif
  3534.  
  3535. #endif # PATHNAME_NOEXT || PATHNAME_RISCOS
  3536.  
  3537. LISPFUN(make_pathname,0,0,norest,key,8,\
  3538.         (kw(defaults),kw(case),kw(host),kw(device),kw(directory),kw(name),kw(type),kw(version)) )
  3539. # (MAKE-PATHNAME [:host] [:device] [:directory] [:name] [:type] [:version]
  3540. #                [:defaults] [:case]),
  3541. # CLTL S. 416, CLtL2 S. 643
  3542.   # Stackaufbau: defaults, case, host, device, directory, name, type, version.
  3543.   { var reg5 boolean logical = FALSE;
  3544.     var reg4 boolean convert = eq(STACK_6,S(Kcommon));
  3545.     # 1. host überprüfen:
  3546.     #ifdef LOGICAL_PATHNAMES
  3547.     # Damit TRANSLATE-PATHNAMES logische Pathnames erzeugen kann:
  3548.     if (logpathnamep(STACK_5))
  3549.       { STACK_5 = TheLogpathname(STACK_5)->pathname_host;
  3550.         logical = TRUE; convert = FALSE;
  3551.       }
  3552.     #endif
  3553.     #if HAS_HOST
  3554.     STACK_5 = test_optional_host(STACK_5,convert);
  3555.     #else
  3556.     STACK_5 = test_optional_host(STACK_5);
  3557.     #endif
  3558.     #ifdef LOGICAL_PATHNAMES
  3559.     if (!nullp(STACK_5) && logical_host_p(STACK_5))
  3560.       { logical = TRUE; convert = FALSE; STACK_5 = string_upcase(STACK_5); }
  3561.     #endif
  3562.     # 2. device überprüfen:
  3563.     #if HAS_DEVICE
  3564.     { var reg1 object device = STACK_4;
  3565.       if (eq(device,unbound)) # angegeben ?
  3566.         { STACK_4 = NIL; } # nein -> verwende NIL
  3567.         else
  3568.         { if (convert) { STACK_4 = device = common_case(device); }
  3569.           if (nullp(device)) goto device_ok; # = NIL ?
  3570.           #ifdef LOGICAL_PATHNAMES
  3571.           elif (logical)
  3572.             { if (logpathnamep(device)) # Pathname -> dessen Device
  3573.                 { STACK_4 = NIL; goto device_ok; }
  3574.             }
  3575.           #endif
  3576.           #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  3577.           elif (eq(device,S(Kwild))) goto device_ok; # = :WILD ?
  3578.           elif (simple_string_p(device)) # Simple-String ?
  3579.             { if (TheSstring(device)->length == 1) # der Länge 1 ?
  3580.                 { var reg2 uintB ch = TheSstring(device)->data[0];
  3581.                   if ((ch >= 'A') && (ch <= 'Z')) # mit Buchstaben >='A' und <='Z' ?
  3582.                     goto device_ok;
  3583.             }   }
  3584.           #endif
  3585.           #ifdef PATHNAME_AMIGAOS
  3586.           elif (simple_string_p(device)) # Simple-String ?
  3587.             { var reg1 uintB* ptr = &TheSstring(device)->data[0];
  3588.               var reg2 uintL count;
  3589.               dotimesL(count,TheSstring(device)->length,
  3590.                 { if (!legal_namechar(*ptr++)) goto device_not_ok; }
  3591.                 );
  3592.               goto device_ok;
  3593.               device_not_ok: ;
  3594.             }
  3595.           #endif
  3596.           #ifdef PATHNAME_RISCOS
  3597.           elif (simple_string_p(device)) # Simple-String ?
  3598.             { var reg2 uintB* ptr = &TheSstring(device)->data[0];
  3599.               var reg3 uintL count;
  3600.               dotimesL(count,TheSstring(device)->length,
  3601.                 { var reg2 uintB ch = *ptr++;
  3602.                   if (!(legal_namechar(ch) && !(ch=='*') && !singlewild_char_p(ch)))
  3603.                     goto device_not_ok;
  3604.                 });
  3605.               goto device_ok;
  3606.               device_not_ok: ;
  3607.             }
  3608.           #endif
  3609.           elif (xpathnamep(device)) # Pathname -> dessen Device
  3610.             {
  3611.               #ifdef LOGICAL_PATHNAMES
  3612.               device = coerce_pathname(device);
  3613.               #endif
  3614.               STACK_4 = ThePathname(device)->pathname_device; goto device_ok;
  3615.             }
  3616.           # Keiner der gewünschten Fälle -> Fehler:
  3617.           pushSTACK(STACK_4); pushSTACK(S(Kdevice)); goto fehler_arg;
  3618.           device_ok: ;
  3619.     }   }
  3620.     #else
  3621.     { var reg1 object device = STACK_4;
  3622.       if (!eq(device,unbound)) # angegeben ?
  3623.         if (!(nullp(device) || xpathnamep(device))) # NIL oder Pathname -> OK
  3624.           # Keiner der gewünschten Fälle -> Fehler:
  3625.           { pushSTACK(STACK_4); pushSTACK(S(Kdevice)); goto fehler_arg; }
  3626.     }
  3627.     #endif
  3628.     # 3. directory überprüfen:
  3629.     { var reg1 object directory = STACK_3;
  3630.       if (eq(directory,unbound) || nullp(directory)) # nicht angegeben oder =NIL ?
  3631.         {
  3632.           #ifdef PATHNAME_AMIGAOS
  3633.           if (!nullp(STACK_4)) # Device angegeben (bei nicht-logical Pathname)?
  3634.             STACK_3 = O(directory_absolute); # Default ist (:ABSOLUTE)
  3635.           else
  3636.           #endif
  3637.             STACK_3 = O(directory_default); # Default ist ([NIL] :RELATIVE)
  3638.           goto directory_ok;
  3639.         }
  3640.       elif (consp(directory)) # ein Cons?
  3641.         { if (convert) { STACK_3 = directory = subst_common_case(directory); }
  3642.           # Der CAR entweder :RELATIVE oder :ABSOLUTE ?
  3643.           if (!consp(directory)) goto directory_bad;
  3644.           { var reg1 object startpoint = Car(directory);
  3645.             if (!(eq(startpoint,S(Krelative)) || eq(startpoint,S(Kabsolute))))
  3646.               goto directory_bad;
  3647.             #ifdef PATHNAME_RISCOS
  3648.             if (!logical && eq(startpoint,S(Kabsolute)))
  3649.               { directory = Cdr(directory);
  3650.                 startpoint = Car(directory);
  3651.                 if (!(eq(startpoint,S(Kroot))
  3652.                       || eq(startpoint,S(Khome))
  3653.                       || eq(startpoint,S(Kcurrent))
  3654.                       || eq(startpoint,S(Klibrary))
  3655.                       || eq(startpoint,S(Kprevious))
  3656.                    ) )
  3657.                   goto directory_bad;
  3658.               }
  3659.             #endif
  3660.           }
  3661.           directory = Cdr(directory);
  3662.           # Subdir-Liste überprüfen:
  3663.           while (consp(directory))
  3664.             { # nächstes subdir überprüfen:
  3665.               var reg1 object subdir = Car(directory);
  3666.               #ifdef LOGICAL_PATHNAMES
  3667.               if (logical)
  3668.                 { if (!(eq(subdir,S(Kwild_inferiors)) || legal_logical_word(subdir)))
  3669.                     goto directory_bad;
  3670.                 }
  3671.                 else
  3672.               #endif
  3673.                 {
  3674.                   #ifdef PATHNAME_EXT83
  3675.                   if (consp(subdir))
  3676.                     { # subdir ist ein Cons
  3677.                       if (!(legal_name(Car(subdir)) && legal_type(Cdr(subdir))))
  3678.                         goto directory_bad;
  3679.                     }
  3680.                     else
  3681.                     { # subdir ist ein Atom
  3682.                       if (!(eq(subdir,S(Kcurrent)) # = :CURRENT ?
  3683.                             || eq(subdir,S(Kparent)) # = :PARENT ?
  3684.                             || eq(subdir,S(Kwild_inferiors)) # = :WILD-INFERIORS ?
  3685.                          ) )
  3686.                         goto directory_bad;
  3687.                     }
  3688.                   #endif
  3689.                   #ifdef PATHNAME_NOEXT
  3690.                   #ifdef PATHNAME_AMIGAOS
  3691.                   if (!(eq(subdir,S(Kwild_inferiors)) || eq(subdir,S(Kparent))
  3692.                         || legal_name(subdir)
  3693.                      ) )
  3694.                     goto directory_bad;
  3695.                   #endif
  3696.                   #if defined(PATHNAME_UNIX) || defined(PATHNAME_OS2)
  3697.                   if (!(eq(subdir,S(Kwild_inferiors)) || legal_name(subdir)))
  3698.                     goto directory_bad;
  3699.                   #endif
  3700.                   #endif
  3701.                   #ifdef PATHNAME_RISCOS
  3702.                   if (!(eq(subdir,S(Kparent)) || legal_name(subdir)))
  3703.                     goto directory_bad;
  3704.                   #endif
  3705.                 }
  3706.               directory = Cdr(directory);
  3707.             }
  3708.           goto directory_ok;
  3709.         }
  3710.       #ifdef LOGICAL_PATHNAMES
  3711.       elif (logical)
  3712.         { if (logpathnamep(directory)) # Pathname -> dessen Directory
  3713.             { STACK_3 = TheLogpathname(directory)->pathname_directory; goto directory_ok; }
  3714.         }
  3715.       #endif
  3716.       elif (xpathnamep(directory)) # Pathname -> dessen Directory
  3717.         {
  3718.           #ifdef LOGICAL_PATHNAMES
  3719.           directory = coerce_pathname(directory);
  3720.           #endif
  3721.           STACK_3 = ThePathname(directory)->pathname_directory; goto directory_ok;
  3722.         }
  3723.       elif (stringp(directory) && legal_name(directory))
  3724.         { var reg1 object new_cons = allocate_cons();
  3725.           Car(new_cons) = S(Kabsolute); Cdr(new_cons) = allocate_cons();
  3726.           Car(Cdr(new_cons)) = directory;
  3727.           STACK_3 = new_cons;
  3728.           goto directory_ok;
  3729.         }
  3730.       # Keiner der gewünschten Fälle -> Fehler:
  3731.       directory_bad:
  3732.       pushSTACK(STACK_3); pushSTACK(S(Kdirectory)); goto fehler_arg;
  3733.       directory_ok: ;
  3734.       #ifdef PATHNAME_AMIGAOS
  3735.       # Bei device /= NIL muß directory mit :ABSOLUTE anfangen:
  3736.       if (!nullp(STACK_4) && !eq(Car(STACK_3),S(Kabsolute))) goto directory_bad;
  3737.       #endif
  3738.     }
  3739.     # 4. name überprüfen:
  3740.     { var reg1 object name = STACK_2;
  3741.       if (convert) { STACK_2 = name = common_case(name); }
  3742.       if (eq(name,unbound))
  3743.         { STACK_2 = NIL; } # nicht angegeben -> verwende NIL
  3744.       elif (nullp(name)) {} # NIL ist OK
  3745.       #ifdef LOGICAL_PATHNAMES
  3746.       elif (logical)
  3747.         { if (legal_logical_word(name)) {} # OK
  3748.           elif (logpathnamep(name)) # Pathname -> dessen Name
  3749.             { STACK_2 = TheLogpathname(name)->pathname_name; }
  3750.           else # Keiner der gewünschten Fälle -> Fehler:
  3751.             { pushSTACK(STACK_2); pushSTACK(S(Kname)); goto fehler_arg; }
  3752.         }
  3753.       #endif
  3754.       #if defined(PATHNAME_NOEXT) || defined(PATHNAME_RISCOS)
  3755.       elif (eq(name,S(Kwild))) { STACK_2 = O(wild_string); } # aus :WILD mache "*"
  3756.       #endif
  3757.       elif (equal(name,O(leer_string))) # name = "" ?
  3758.         { STACK_2 = NIL; } # ja -> verwende NIL
  3759.       elif (legal_name(name)) {} # zulässiger Name ist OK
  3760.       elif (xpathnamep(name)) # Pathname -> dessen Name
  3761.         {
  3762.           #ifdef LOGICAL_PATHNAMES
  3763.           name = coerce_pathname(name);
  3764.           #endif
  3765.           STACK_2 = ThePathname(name)->pathname_name;
  3766.         }
  3767.       else # Keiner der gewünschten Fälle -> Fehler:
  3768.         { pushSTACK(STACK_2); pushSTACK(S(Kname)); goto fehler_arg; }
  3769.     }
  3770.     # 5. type überprüfen:
  3771.     { var reg1 object type = STACK_1;
  3772.       if (convert) { STACK_1 = type = common_case(type); }
  3773.       if (eq(type,unbound))
  3774.         { STACK_1 = NIL; } # nicht angegeben -> verwende NIL
  3775.       elif (nullp(type)) {} # NIL ist OK
  3776.       #ifdef LOGICAL_PATHNAMES
  3777.       elif (logical)
  3778.         { if (legal_logical_word(type)) {} # OK
  3779.           elif (logpathnamep(type)) # Pathname -> dessen Typ
  3780.             { STACK_1 = TheLogpathname(type)->pathname_type; }
  3781.           else # Keiner der gewünschten Fälle -> Fehler:
  3782.             { pushSTACK(STACK_1); pushSTACK(S(Ktype)); goto fehler_arg; }
  3783.         }
  3784.       #endif
  3785.       #if defined(PATHNAME_NOEXT) || defined(PATHNAME_RISCOS)
  3786.       elif (eq(type,S(Kwild))) { STACK_1 = O(wild_string); } # aus :WILD mache "*"
  3787.       #endif
  3788.       elif (legal_type(type)) {} # zulässiger Typ ist OK
  3789.       elif (xpathnamep(type)) # Pathname -> dessen Typ
  3790.         {
  3791.           #ifdef LOGICAL_PATHNAMES
  3792.           type = coerce_pathname(type);
  3793.           #endif
  3794.           STACK_1 = ThePathname(type)->pathname_type;
  3795.         }
  3796.       else # Keiner der gewünschten Fälle -> Fehler:
  3797.         { pushSTACK(STACK_1); pushSTACK(S(Ktype)); goto fehler_arg; }
  3798.     }
  3799.     # 6. version überprüfen:
  3800.     #if HAS_VERSION || defined(LOGICAL_PATHNAMES)
  3801.     STACK_0 = test_optional_version(NIL); # Default ist NIL
  3802.     #else
  3803.     test_optional_version(NIL);
  3804.     #endif
  3805.     # 7. Pathname bauen:
  3806.     {var reg1 object pathname;
  3807.      #ifdef LOGICAL_PATHNAMES
  3808.      if (logical)
  3809.        { pathname = allocate_logpathname(); # neuer Logical Pathname
  3810.          TheLogpathname(pathname)->pathname_version   = popSTACK();
  3811.          TheLogpathname(pathname)->pathname_type      = popSTACK();
  3812.          TheLogpathname(pathname)->pathname_name      = popSTACK();
  3813.          TheLogpathname(pathname)->pathname_directory = popSTACK();
  3814.          skipSTACK(1);
  3815.          TheLogpathname(pathname)->pathname_host      = popSTACK();
  3816.        }
  3817.        else
  3818.      #endif
  3819.        { pathname = allocate_pathname(); # neuer Pathname
  3820.          #if HAS_VERSION
  3821.          ThePathname(pathname)->pathname_version   = popSTACK();
  3822.          #else
  3823.          skipSTACK(1);
  3824.          #endif
  3825.          ThePathname(pathname)->pathname_type      = popSTACK();
  3826.          ThePathname(pathname)->pathname_name      = popSTACK();
  3827.          ThePathname(pathname)->pathname_directory = popSTACK();
  3828.          #if HAS_DEVICE
  3829.          ThePathname(pathname)->pathname_device    = popSTACK();
  3830.          #else
  3831.          skipSTACK(1);
  3832.          #endif
  3833.          #if HAS_HOST
  3834.          ThePathname(pathname)->pathname_host      = popSTACK();
  3835.          #else
  3836.          skipSTACK(1);
  3837.          #endif
  3838.        }
  3839.     skipSTACK(1); # case vergessen
  3840.     # 8. evtl. Defaults hineinmergen:
  3841.      {var reg2 object defaults = popSTACK();
  3842.       if (eq(defaults,unbound))
  3843.         # keine Defaults angegeben -> pathname als Wert
  3844.         { value1 = pathname; }
  3845.         else
  3846.         # (MERGE-PATHNAMES pathname defaults [nil]) aufrufen:
  3847.         { pushSTACK(pathname); pushSTACK(defaults); pushSTACK(NIL);
  3848.           funcall(L(merge_pathnames),3);
  3849.         }
  3850.       mv_count=1;
  3851.       return;
  3852.     }}
  3853.     # Fehlermeldung:
  3854.     fehler_arg:
  3855.     pushSTACK(TheSubr(subr_self)->name);
  3856.     //: DEUTSCH "~: Unzulässiges ~-Argument ~"
  3857.     //: ENGLISH "~: illegal ~ argument ~"
  3858.     //: FRANCAIS "~ : Argument incorrect pour ~ : ~"
  3859.     fehler(error, GETTEXT("~: illegal ~ argument ~"));
  3860.   }
  3861.  
  3862. #ifdef LOGICAL_PATHNAMES
  3863.  
  3864. LISPFUN(make_logical_pathname,0,0,norest,key,8,\
  3865.         (kw(defaults),kw(case),kw(host),kw(device),kw(directory),kw(name),kw(type),kw(version)) )
  3866. # (MAKE-LOGICAL-PATHNAME [:host] [:device] [:directory] [:name] [:type] [:version]
  3867. #                        [:defaults] [:case]),
  3868. # wie MAKE-PATHNAME, nur daß ein Logical Pathname gebildet wird.
  3869.   { # Ein logischer Pathname als :HOST-Argument zu MAKE-PATHNAME
  3870.     # erzwingt einen logischen Pathname als Ergebnis.
  3871.     var reg1 object obj = allocate_logpathname();
  3872.     TheLogpathname(obj)->pathname_host = (!eq(STACK_5,unbound) ? STACK_5 : NIL);
  3873.     STACK_5 = obj;
  3874.     # weiter bei MAKE-PATHNAME.
  3875.     C_make_pathname();
  3876.   }
  3877.  
  3878. #endif
  3879.  
  3880. #ifdef USER_HOMEDIR
  3881. LISPFUN(user_homedir_pathname,0,1,norest,nokey,0,NIL)
  3882. # (USER-HOMEDIR-PATHNAME [host]), CLTL S. 418
  3883.   {
  3884.     #if HAS_HOST
  3885.     STACK_0 = test_optional_host(STACK_0,FALSE); # Host überprüfen
  3886.     #ifdef PATHNAME_RISCOS
  3887.     {var reg1 object pathname = allocate_pathname(); # neuer Pathname
  3888.      ThePathname(pathname)->pathname_host      = popSTACK();
  3889.      #if HAS_DEVICE
  3890.      ThePathname(pathname)->pathname_device    = NIL;
  3891.      #endif
  3892.      ThePathname(pathname)->pathname_directory = O(directory_homedir);
  3893.      ThePathname(pathname)->pathname_name      = NIL;
  3894.      ThePathname(pathname)->pathname_type      = NIL;
  3895.      #if HAS_VERSION
  3896.      ThePathname(pathname)->pathname_version   = NIL;
  3897.      #endif
  3898.      value1 = pathname;
  3899.     }
  3900.     #else
  3901.     ??
  3902.     #endif
  3903.     #else
  3904.     test_optional_host(popSTACK()); # Host überprüfen und ignorieren
  3905.     value1 = O(user_homedir); # User-Homedir-Pathname
  3906.     #endif
  3907.     mv_count=1; # als Wert
  3908.   }
  3909. #endif
  3910.  
  3911. # UP: Kopiert einen Pathname.
  3912. # copy_pathname(pathname)
  3913. # > pathname: nicht-Logical Pathname
  3914. # < ergebnis: Kopie des Pathname, mit denselben Komponenten
  3915. # kann GC auslösen
  3916.   local object copy_pathname (object pathname);
  3917.   local object copy_pathname(pathname)
  3918.     var reg2 object pathname;
  3919.     { pushSTACK(pathname);
  3920.      {var reg1 object new = allocate_pathname();
  3921.       pathname = popSTACK();
  3922.       #if HAS_HOST
  3923.       ThePathname(new)->pathname_host      = ThePathname(pathname)->pathname_host     ;
  3924.       #endif
  3925.       #if HAS_DEVICE
  3926.       ThePathname(new)->pathname_device    = ThePathname(pathname)->pathname_device   ;
  3927.       #endif
  3928.       ThePathname(new)->pathname_directory = ThePathname(pathname)->pathname_directory;
  3929.       ThePathname(new)->pathname_name      = ThePathname(pathname)->pathname_name     ;
  3930.       ThePathname(new)->pathname_type      = ThePathname(pathname)->pathname_type     ;
  3931.       #if HAS_VERSION
  3932.       ThePathname(new)->pathname_version   = ThePathname(pathname)->pathname_version  ;
  3933.       #endif
  3934.       return new;
  3935.     }}
  3936.  
  3937. # Wildcards
  3938. # =========
  3939.  
  3940. #if defined(PATHNAME_NOEXT) || defined(PATHNAME_RISCOS)
  3941. # UP: Testet, ob ein Simple-String Wildcards enthält.
  3942. # has_wildcards(string)
  3943. # > string: Simple-String
  3944. # < ergebnis: TRUE wenn string Wildcard-Zeichen enthält
  3945.   local boolean has_wildcards (object string);
  3946.   local boolean has_wildcards(string)
  3947.     var reg4 object string;
  3948.     { var reg3 uintL len = TheSstring(string)->length;
  3949.       var reg2 uintB* charptr = &TheSstring(string)->data[0];
  3950.       dotimesL(len,len,
  3951.         { var reg1 uintB ch = *charptr++;
  3952.           if ((ch=='*') # Wildcard für beliebig viele Zeichen
  3953.               || singlewild_char_p(ch) # Wildcard für genau ein Zeichen
  3954.              )
  3955.             { return TRUE; }
  3956.         });
  3957.       return FALSE;
  3958.     }
  3959. #endif
  3960.  
  3961. #ifdef LOGICAL_PATHNAMES
  3962. # UP: Testet, ob ein Simple-String Wildcards enthält.
  3963. # has_word_wildcards(string)
  3964. # > string: Simple-String
  3965. # < ergebnis: TRUE wenn string Wildcard-Zeichen enthält
  3966.   local boolean has_word_wildcards (object string);
  3967.   local boolean has_word_wildcards(string)
  3968.     var reg3 object string;
  3969.     { var reg2 uintL len = TheSstring(string)->length;
  3970.       var reg1 uintB* charptr = &TheSstring(string)->data[0];
  3971.       dotimesL(len,len, { if (*charptr++ == '*') { return TRUE; } } );
  3972.       return FALSE;
  3973.     }
  3974. #endif
  3975.  
  3976. # UP: Testet, ob die Host-Komponente eines Pathname Wildcards enthält.
  3977. # has_host_wildcards(pathname)
  3978. # > pathname: Pathname
  3979. # < ergebnis: TRUE wenn (PATHNAME-HOST pathname) Wildcards enthält.
  3980.   local boolean has_host_wildcards (object pathname);
  3981.   # Host kann keine Wildcards enthalten.
  3982.   #define has_host_wildcards(pathname)  (unused (pathname), FALSE)
  3983.  
  3984. # UP: Testet, ob die Device-Komponente eines Pathname Wildcards enthält.
  3985. # has_device_wildcards(pathname)
  3986. # > pathname: Pathname
  3987. # < ergebnis: TRUE wenn (PATHNAME-DEVICE pathname) Wildcards enthält.
  3988.   local boolean has_device_wildcards (object pathname);
  3989.   local boolean has_device_wildcards(pathname)
  3990.     var reg1 object pathname;
  3991.     {
  3992.       #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  3993.       #ifdef LOGICAL_PATHNAMES
  3994.       if (logpathnamep(pathname))
  3995.         return FALSE;
  3996.       #endif
  3997.       # Device überprüfen: = :WILD ?
  3998.       return eq(ThePathname(pathname)->pathname_device,S(Kwild));
  3999.       #else
  4000.       return FALSE;
  4001.       #endif
  4002.     }
  4003.  
  4004. # UP: Testet, ob die Directory-Komponente eines Pathname Wildcards enthält.
  4005. # has_directory_wildcards(pathname)
  4006. # > pathname: Pathname
  4007. # < ergebnis: TRUE wenn (PATHNAME-DIRECTORY pathname) Wildcards enthält.
  4008.   local boolean has_directory_wildcards (object pathname);
  4009.   local boolean has_directory_wildcards(pathname)
  4010.     var reg3 object pathname;
  4011.     { # Directory überprüfen:
  4012.       #ifdef LOGICAL_PATHNAMES
  4013.       if (logpathnamep(pathname))
  4014.         { var reg1 object directory = TheLogpathname(pathname)->pathname_directory;
  4015.           while (consp(directory = Cdr(directory)))
  4016.             { var reg2 object subdir = Car(directory);
  4017.               if (simple_string_p(subdir))
  4018.                 { if (has_word_wildcards(subdir)) return TRUE; }
  4019.                 else
  4020.                 { if (eq(subdir,S(Kwild)) || eq(subdir,S(Kwild_inferiors)))
  4021.                     return TRUE;
  4022.             }   }
  4023.           return FALSE;
  4024.         }
  4025.       #endif
  4026.      {var reg1 object directory = ThePathname(pathname)->pathname_directory;
  4027.       while (consp(directory = Cdr(directory)))
  4028.         { var reg2 object subdir = Car(directory);
  4029.           #ifdef PATHNAME_EXT83
  4030.           if (consp(subdir))
  4031.             { # subdir ist ein Cons. name oder type = :WILD ?
  4032.               if (eq(Car(subdir),S(Kwild)) || eq(Cdr(subdir),S(Kwild)))
  4033.                 return TRUE;
  4034.             }
  4035.             else
  4036.             { # subdir ist ein Atom. = :WILD-INFERIORS ?
  4037.               if (eq(subdir,S(Kwild_inferiors)))
  4038.                 return TRUE;
  4039.             }
  4040.           #endif
  4041.           #ifdef PATHNAME_NOEXT
  4042.           if (simple_string_p(subdir))
  4043.             { if (has_wildcards(subdir)) return TRUE; }
  4044.             else
  4045.             { if (eq(subdir,S(Kwild_inferiors))) return TRUE; }
  4046.           #endif
  4047.           #ifdef PATHNAME_RISCOS
  4048.           if (simple_string_p(subdir))
  4049.             { if (has_wildcards(subdir)) return TRUE; }
  4050.           #endif
  4051.         }
  4052.       return FALSE;
  4053.     }}
  4054.  
  4055. # UP: Testet, ob die Name-Komponente eines Pathname Wildcards enthält.
  4056. # has_name_wildcards(pathname)
  4057. # > pathname: Pathname
  4058. # < ergebnis: TRUE wenn (PATHNAME-NAME pathname) Wildcards enthält.
  4059.   local boolean has_name_wildcards (object pathname);
  4060.   local boolean has_name_wildcards(pathname)
  4061.     var reg2 object pathname;
  4062.     { # Name überprüfen:
  4063.       #ifdef LOGICAL_PATHNAMES
  4064.       if (logpathnamep(pathname))
  4065.         { var reg1 object name = TheLogpathname(pathname)->pathname_name;
  4066.           if (simple_string_p(name))
  4067.             { if (has_word_wildcards(name)) return TRUE; }
  4068.             else
  4069.             { if (eq(name,S(Kwild))) return TRUE; }
  4070.           return FALSE;
  4071.         }
  4072.       #endif
  4073.       #ifdef PATHNAME_EXT83
  4074.       if (eq(ThePathname(pathname)->pathname_name,S(Kwild))) # Name = :WILD ?
  4075.         return TRUE;
  4076.       #endif
  4077.       #if defined(PATHNAME_NOEXT) || defined(PATHNAME_RISCOS)
  4078.       { var reg1 object name = ThePathname(pathname)->pathname_name;
  4079.         if (simple_string_p(name))
  4080.           { if (has_wildcards(name)) return TRUE; }
  4081.       }
  4082.       #endif
  4083.       return FALSE;
  4084.     }
  4085.  
  4086. # UP: Testet, ob die Type-Komponente eines Pathname Wildcards enthält.
  4087. # has_type_wildcards(pathname)
  4088. # > pathname: Pathname
  4089. # < ergebnis: TRUE wenn (PATHNAME-TYPE pathname) Wildcards enthält.
  4090.   local boolean has_type_wildcards (object pathname);
  4091.   local boolean has_type_wildcards(pathname)
  4092.     var reg2 object pathname;
  4093.     { # Typ überprüfen:
  4094.       #ifdef LOGICAL_PATHNAMES
  4095.       if (logpathnamep(pathname))
  4096.         { var reg1 object type = TheLogpathname(pathname)->pathname_type;
  4097.           if (simple_string_p(type))
  4098.             { if (has_word_wildcards(type)) return TRUE; }
  4099.             else
  4100.             { if (eq(type,S(Kwild))) return TRUE; }
  4101.           return FALSE;
  4102.         }
  4103.       #endif
  4104.       #ifdef PATHNAME_EXT83
  4105.       if (eq(ThePathname(pathname)->pathname_type,S(Kwild))) # Typ = :WILD ?
  4106.         return TRUE;
  4107.       #endif
  4108.       #if defined(PATHNAME_NOEXT) || defined(PATHNAME_RISCOS)
  4109.       { var reg1 object type = ThePathname(pathname)->pathname_type;
  4110.         if (simple_string_p(type))
  4111.           { if (has_wildcards(type)) return TRUE; }
  4112.       }
  4113.       #endif
  4114.       return FALSE;
  4115.     }
  4116.  
  4117. # UP: Testet, ob die Version-Komponente eines Pathname Wildcards enthält.
  4118. # has_version_wildcards(pathname)
  4119. # > pathname: Pathname
  4120. # < ergebnis: TRUE wenn (PATHNAME-VERSION pathname) Wildcards enthält.
  4121.   local boolean has_version_wildcards (object pathname);
  4122.   local boolean has_version_wildcards(pathname)
  4123.     var reg2 object pathname;
  4124.     { # Version überprüfen:
  4125.       #ifdef LOGICAL_PATHNAMES
  4126.       if (logpathnamep(pathname))
  4127.         { if (eq(TheLogpathname(pathname)->pathname_version,S(Kwild)))
  4128.             return TRUE;
  4129.           return FALSE;
  4130.         }
  4131.       #endif
  4132.       return FALSE;
  4133.     }
  4134.  
  4135. # UP: Testet, ob irgendeine Komponente eines Pathname Wildcards enthält.
  4136. # has_some_wildcards(pathname)
  4137. # > pathname: Pathname
  4138. # < ergebnis: TRUE wenn pathname Wildcards enthält.
  4139.   local boolean has_some_wildcards (object pathname);
  4140.   local boolean has_some_wildcards(pathname)
  4141.     var reg1 object pathname;
  4142.     { if (has_host_wildcards(pathname)) return TRUE;
  4143.       if (has_device_wildcards(pathname)) return TRUE;
  4144.       if (has_directory_wildcards(pathname)) return TRUE;
  4145.       if (has_name_wildcards(pathname)) return TRUE;
  4146.       if (has_type_wildcards(pathname)) return TRUE;
  4147.       if (has_version_wildcards(pathname)) return TRUE;
  4148.       return FALSE;
  4149.     }
  4150.  
  4151. # UP: Überprüft, ob ein Pathname keine Wildcards enthält.
  4152. # check_no_wildcards(pathname);
  4153. # > pathname: Pathname
  4154.   local void check_no_wildcards (object pathname);
  4155.   local void check_no_wildcards(pathname)
  4156.     var reg2 object pathname;
  4157.     { if (!has_some_wildcards(pathname))
  4158.         # Keine Wildcards gefunden.
  4159.         return;
  4160.       # Fehlermeldung, wenn der Pathname Wildcards enthält:
  4161.       pushSTACK(pathname); # Wert für Slot PATHNAME von FILE-ERROR
  4162.       pushSTACK(pathname);
  4163.       //: DEUTSCH "Hier sind keine Wildcards (Dateiquantoren) erlaubt: ~"
  4164.       //: ENGLISH "wildcards are not allowed here: ~"
  4165.       //: FRANCAIS "Les caractères joker ne sont pas permis ici : ~"
  4166.       fehler(file_error, GETTEXT("wildcards are not allowed here: ~"));
  4167.     }
  4168.  
  4169. LISPFUN(wild_pathname_p,1,1,norest,nokey,0,NIL)
  4170. # (WILD-PATHNAME-P pathname [field-key]), CLtL2 S. 623
  4171.   { var reg3 object pathname = coerce_xpathname(STACK_1);
  4172.     var reg1 object key = STACK_0;
  4173.     var reg2 boolean erg;
  4174.     if (eq(key,unbound) || nullp(key)) { erg = has_some_wildcards(pathname); }
  4175.     elif (eq(key,S(Khost))) { erg = has_host_wildcards(pathname); }
  4176.     elif (eq(key,S(Kdevice))) { erg = has_device_wildcards(pathname); }
  4177.     elif (eq(key,S(Kdirectory))) { erg = has_directory_wildcards(pathname); }
  4178.     elif (eq(key,S(Kname))) { erg = has_name_wildcards(pathname); }
  4179.     elif (eq(key,S(Ktype))) { erg = has_type_wildcards(pathname); }
  4180.     elif (eq(key,S(Kversion))) { erg = has_version_wildcards(pathname); }
  4181.     else
  4182.       { pushSTACK(key); # Wert für Slot DATUM von TYPE-ERROR
  4183.         pushSTACK(O(type_pathname_field_key)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  4184.         pushSTACK(NIL);
  4185.         pushSTACK(S(Kversion));
  4186.         pushSTACK(S(Ktype));
  4187.         pushSTACK(S(Kname));
  4188.         pushSTACK(S(Kdirectory));
  4189.         pushSTACK(S(Kdevice));
  4190.         pushSTACK(S(Khost));
  4191.         pushSTACK(key);
  4192.         pushSTACK(TheSubr(subr_self)->name);
  4193.         //: DEUTSCH "~: Argument ~ sollte ~, ~, ~, ~, ~, ~ oder ~ sein."
  4194.         //: ENGLISH "~: argument ~ should be ~, ~, ~, ~, ~, ~ or ~"
  4195.         //: FRANCAIS "~ : L'argument ~ devrait être ~, ~, ~, ~, ~, ~ ou ~ ."
  4196.         fehler(type_error, GETTEXT("~: argument ~ should be ~, ~, ~, ~, ~, ~ or ~"));
  4197.       }
  4198.     value1 = (erg ? T : NIL); mv_count=1; # boolescher Wert
  4199.     skipSTACK(2);
  4200.   }
  4201.  
  4202. #if defined(PATHNAME_NOEXT) || defined(LOGICAL_PATHNAMES)
  4203.  
  4204.   # UP: Matcht einen Wildcard-String ("Muster") mit einem "Beispiel".
  4205.   # > muster: Simple-String, mit Platzhaltern
  4206.   #           '?' für genau 1 Zeichen
  4207.   #           '*' für beliebig viele Zeichen
  4208.   # > beispiel: Simple-String, der damit zu matchen ist
  4209.   local boolean wildcard_match (object muster, object beispiel);
  4210.   # rekursive Implementation wegen Backtracking:
  4211.   local boolean wildcard_match_ab (uintL m_count, uintB* m_ptr, uintL b_count, uintB* b_ptr);
  4212.   local boolean wildcard_match(muster,beispiel)
  4213.     var reg2 object muster;
  4214.     var reg1 object beispiel;
  4215.     { return wildcard_match_ab(
  4216.                                /* m_count = */ TheSstring(muster)->length,
  4217.                                /* m_ptr   = */ &TheSstring(muster)->data[0],
  4218.                                /* b_count = */ TheSstring(beispiel)->length,
  4219.                                /* b_ptr   = */ &TheSstring(beispiel)->data[0]
  4220.                               );
  4221.     }
  4222.   local boolean wildcard_match_ab(m_count,m_ptr,b_count,b_ptr)
  4223.     var reg5 uintL m_count;
  4224.     var reg2 uintB* m_ptr;
  4225.     var reg4 uintL b_count;
  4226.     var reg1 uintB* b_ptr;
  4227.     { var reg3 uintB c;
  4228.       loop
  4229.         { if (m_count==0)
  4230.             { return (b_count==0 ? TRUE : FALSE); } # "" matcht nur ""
  4231.           m_count--;
  4232.           c = *m_ptr++; # nächstes Match-Zeichen
  4233.           if (c=='?') # Wildcard '?'
  4234.             { if (b_count==0) return FALSE; # mindestens ein Zeichen muß noch kommen
  4235.               b_count--; b_ptr++; # es wird ignoriert
  4236.             }
  4237.           elif (c=='*') break; # Wildcard '*' später
  4238.           else # alles andere muß genau matchen:
  4239.             { if (b_count==0) return FALSE;
  4240.               b_count--; if (!equal_pathchar(*b_ptr++,c)) return FALSE;
  4241.             }
  4242.         }
  4243.       # Wildcard '*': Suche nächstes non-Wildcard-Zeichen und zähle die '?'
  4244.       # mit (denn eine Folge '*??*???***?' matcht alles, was mindestens so
  4245.       # lang ist, wie die Folge Fragezeichen enthält). Man kann die '?' auch
  4246.       # gleich verwerten, denn '*??*???***?' ist zu '??????*' äquivalent.
  4247.       loop
  4248.         { if (m_count==0) return TRUE; # Wildcard am Ende matcht den Rest.
  4249.           m_count--;
  4250.           c = *m_ptr++; # nächstes Match-Zeichen
  4251.           if (c=='?') # Fragezeichen: nach vorne ziehen, sofort abarbeiten
  4252.             { if (b_count==0) return FALSE;
  4253.               b_count--; b_ptr++;
  4254.             }
  4255.           elif (!(c=='*')) break;
  4256.         }
  4257.       # c = nächstes non-Wildcard-Zeichen. Suche es.
  4258.       loop
  4259.         { if (b_count==0) return FALSE; # c nicht gefunden
  4260.           b_count--;
  4261.           if (equal_pathchar(*b_ptr++,c))
  4262.             { if (wildcard_match_ab(m_count,m_ptr,b_count,b_ptr))
  4263.                 return TRUE;
  4264.         }   }
  4265.     }
  4266.  
  4267. #endif
  4268.  
  4269. # UPs: Matcht jeweils eine Pathname-Komponente ("Beispiel") und
  4270. # eine Pathname-Komponente ("Muster").
  4271.   local boolean host_match (object muster, object beispiel, boolean logical);
  4272.   local boolean device_match (object muster, object beispiel, boolean logical);
  4273.   local boolean directory_match (object muster, object beispiel, boolean logical);
  4274.   local boolean nametype_match (object muster, object beispiel, boolean logical);
  4275.   local boolean version_match (object muster, object beispiel, boolean logical);
  4276.   local boolean host_match(muster,beispiel,logical)
  4277.     var reg2 object muster;
  4278.     var reg1 object beispiel;
  4279.     var reg3 boolean logical;
  4280.     {
  4281.       #ifdef LOGICAL_PATHNAMES
  4282.       if (logical)
  4283.         { return equal(muster,beispiel); }
  4284.       #endif
  4285.       #if HAS_HOST
  4286.       return equal(muster,beispiel);
  4287.       #else
  4288.       return TRUE;
  4289.       #endif
  4290.     }
  4291.   local boolean device_match(muster,beispiel,logical)
  4292.     var reg2 object muster;
  4293.     var reg1 object beispiel;
  4294.     var reg3 boolean logical;
  4295.     {
  4296.       #if HAS_DEVICE
  4297.       #ifdef LOGICAL_PATHNAMES
  4298.       if (logical)
  4299.         { return TRUE; }
  4300.       #endif
  4301.       #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  4302.       if (eq(muster,S(Kwild))) return TRUE;
  4303.       if (eq(beispiel,S(Kwild))) return FALSE;
  4304.       #endif
  4305.       #if defined(PATHNAME_AMIGAOS) || defined(PATHNAME_OS2)
  4306.       return equalp(muster,beispiel);
  4307.       #else
  4308.       return equal(muster,beispiel);
  4309.       #endif
  4310.       #else
  4311.       return TRUE;
  4312.       #endif
  4313.     }
  4314.   local boolean nametype_match(muster,beispiel,logical)
  4315.     var reg2 object muster;
  4316.     var reg1 object beispiel;
  4317.     var reg3 boolean logical;
  4318.     {
  4319.       #ifdef LOGICAL_PATHNAMES
  4320.       if (logical)
  4321.         { if (eq(muster,S(Kwild))) return TRUE;
  4322.           if (eq(beispiel,S(Kwild))) return FALSE;
  4323.           if (nullp(muster))
  4324.             { if (nullp(beispiel)) return TRUE; else return FALSE; }
  4325.           if (nullp(beispiel))
  4326.             { return FALSE; }
  4327.           return wildcard_match(muster,beispiel);
  4328.         }
  4329.       #endif
  4330.       #ifdef PATHNAME_EXT83
  4331.       if (eq(muster,S(Kwild))) return TRUE;
  4332.       if (eq(beispiel,S(Kwild))) return FALSE;
  4333.       return equal(muster,beispiel);
  4334.       #endif
  4335.       #ifdef PATHNAME_NOEXT
  4336.       if (nullp(muster))
  4337.         { if (nullp(beispiel)) return TRUE; else return FALSE; }
  4338.       if (nullp(beispiel))
  4339.         { return FALSE; }
  4340.       return wildcard_match(muster,beispiel);
  4341.       #endif
  4342.     }
  4343.   local boolean subdir_match(muster,beispiel,logical)
  4344.     var reg2 object muster;
  4345.     var reg1 object beispiel;
  4346.     var reg3 boolean logical;
  4347.     { if (eq(muster,beispiel)) return TRUE;
  4348.       #ifdef LOGICAL_PATHNAMES
  4349.       if (logical)
  4350.         { if (eq(muster,S(Kwild))) return TRUE;
  4351.           if (!simple_string_p(muster) || !simple_string_p(beispiel)) return FALSE;
  4352.           return wildcard_match(muster,beispiel);
  4353.         }
  4354.       #endif
  4355.       #ifdef PATHNAME_EXT83
  4356.       if (atomp(muster) || atomp(beispiel)) return FALSE;
  4357.       return (nametype_match(Car(muster),Car(beispiel),FALSE)
  4358.               && nametype_match(Cdr(muster),Cdr(beispiel),FALSE)
  4359.              );
  4360.       #endif
  4361.       #ifdef PATHNAME_NOEXT
  4362.       if (!simple_string_p(muster) || !simple_string_p(beispiel)) return FALSE;
  4363.       return wildcard_match(muster,beispiel);
  4364.       #endif
  4365.     }
  4366.   # rekursive Implementation wegen Backtracking:
  4367.   local boolean directory_match_ab (object m_list, object b_list, boolean logical);
  4368.   local boolean directory_match_ab(m_list,b_list,logical)
  4369.     var reg2 object m_list;
  4370.     var reg1 object b_list;
  4371.     var reg4 boolean logical;
  4372.     { # Algorithmus analog zu wildcard_match_ab.
  4373.       var reg3 object item;
  4374.       loop
  4375.         { if (atomp(m_list)) { return atomp(b_list); }
  4376.           item = Car(m_list); m_list = Cdr(m_list);
  4377.           if (eq(item,S(Kwild_inferiors))) break;
  4378.           if (atomp(b_list)) return FALSE;
  4379.           if (!subdir_match(item,Car(b_list),logical)) return FALSE;
  4380.           b_list = Cdr(b_list);
  4381.         }
  4382.       loop
  4383.         { if (atomp(m_list)) return TRUE;
  4384.           item = Car(m_list); m_list = Cdr(m_list);
  4385.           if (!eq(item,S(Kwild_inferiors))) break;
  4386.         }
  4387.       loop
  4388.         { if (atomp(b_list)) return FALSE;
  4389.           if (subdir_match(item,Car(b_list),logical))
  4390.             { b_list = Cdr(b_list);
  4391.               if (directory_match_ab(m_list,b_list,logical)) return TRUE;
  4392.             }
  4393.             else
  4394.             { b_list = Cdr(b_list); }
  4395.         }
  4396.     }
  4397.   local boolean directory_match(muster,beispiel,logical)
  4398.     var reg2 object muster;
  4399.     var reg1 object beispiel;
  4400.     var reg3 boolean logical;
  4401.     {
  4402.       # Startpoint matchen:
  4403.       if (!eq(Car(muster),Car(beispiel)))
  4404.         return FALSE;
  4405.       muster = Cdr(muster); beispiel = Cdr(beispiel);
  4406.       # subdirs matchen:
  4407.       return directory_match_ab(muster,beispiel,logical);
  4408.     }
  4409.   local boolean version_match(muster,beispiel,logical)
  4410.     var reg2 object muster;
  4411.     var reg1 object beispiel;
  4412.     var reg3 boolean logical;
  4413.     {
  4414.       #ifdef LOGICAL_PATHNAMES
  4415.       if (logical)
  4416.         { if (eq(muster,S(Kwild))) return TRUE;
  4417.           return eql(muster,beispiel);
  4418.         }
  4419.       #endif
  4420.       #if HAS_VERSION
  4421.       if (eq(muster,S(Kwild))) return TRUE;
  4422.       if (eq(beispiel,S(Kwild))) return FALSE;
  4423.       if (eql(muster,beispiel)) return TRUE;
  4424.       return FALSE;
  4425.       #else
  4426.       return TRUE;
  4427.       #endif
  4428.     }
  4429.  
  4430. LISPFUNN(pathname_match_p,2)
  4431. # (PATHNAME-MATCH-P pathname wildname), CLtL2 S. 623
  4432.   { # Stackaufbau: pathname, wildname.
  4433.     var reg3 boolean logical = FALSE;
  4434.     STACK_1 = coerce_xpathname(STACK_1);
  4435.     STACK_0 = coerce_xpathname(STACK_0);
  4436.     #ifdef LOGICAL_PATHNAMES
  4437.     if (logpathnamep(STACK_1) && logpathnamep(STACK_0))
  4438.       { logical = TRUE; }
  4439.       else
  4440.       # nicht beides logische Pathnames -> erst in normale Pathnames umwandeln:
  4441.       { STACK_1 = coerce_pathname(STACK_1);
  4442.         STACK_0 = coerce_pathname(STACK_0);
  4443.       }
  4444.     #endif
  4445.    {var reg2 object wildname = popSTACK();
  4446.     var reg1 object pathname = popSTACK();
  4447.     if (!host_match(xpathname_host(logical,wildname),
  4448.                     xpathname_host(logical,pathname),
  4449.                     logical
  4450.        )           )
  4451.       goto no;
  4452.     if (!device_match(xpathname_device(logical,wildname),
  4453.                       xpathname_device(logical,pathname),
  4454.                       logical
  4455.        )             )
  4456.       goto no;
  4457.     if (!directory_match(xpathname_directory(logical,wildname),
  4458.                          xpathname_directory(logical,pathname),
  4459.                          logical
  4460.        )                )
  4461.       goto no;
  4462.     if (!nametype_match(xpathname_name(logical,wildname),
  4463.                         xpathname_name(logical,pathname),
  4464.                         logical
  4465.        )               )
  4466.       goto no;
  4467.     if (!nametype_match(xpathname_type(logical,wildname),
  4468.                         xpathname_type(logical,pathname),
  4469.                         logical
  4470.        )               )
  4471.       goto no;
  4472.     if (!version_match(xpathname_version(logical,wildname),
  4473.                        xpathname_version(logical,pathname),
  4474.                        logical
  4475.        )              )
  4476.       goto no;
  4477.     yes: value1 = T; mv_count=1; return;
  4478.     no: value1 = NIL; mv_count=1; return;
  4479.   }}
  4480.  
  4481. # (TRANSLATE-PATHNAME beispiel muster1 muster2) machen wir folgendermaßen:
  4482. # 1. (PATHNAME-MATCH-P beispiel muster1) nachrechnen, dabei aber die
  4483. #    Substitution aufheben, in Form von Textstücken (:WILD -> "*").
  4484. # 2. In muster2 die Textstücke einsetzen, bis muster2 voll ist oder die
  4485. #    Textstücke aufgebraucht sind.
  4486. # 3. Zum Schluß (MERGE-PATHNAMES modifiziertes_muster2 beispiel).
  4487.  
  4488.   # UP: Vergleicht einen Wildcard-String ("Muster") mit einem "Beispiel".
  4489.   # wildcard_diff(muster,beispiel,previous,solutions);
  4490.   # > muster: Simple-String, mit Platzhaltern
  4491.   #           '?' für genau 1 Zeichen
  4492.   #           '*' für beliebig viele Zeichen
  4493.   # > beispiel: Simple-String, der damit zu vergleichen ist
  4494.   # > previous: bisher bekanntes Vergleichsergebnis
  4495.   #             (umgedrehte Liste von Simple-Strings und Listen)
  4496.   # > solutions: Pointer auf eine Liste im STACK, auf die die
  4497.   #              Vergleichsergebnisse (umgedrehte Liste von Simple-Strings und
  4498.   #              Listen) zu consen sind
  4499.   # kann GC auslösen
  4500.  
  4501.   # Hier wünscht man sich nicht Lisp oder C, sondern PROLOG als Sprache!
  4502.  
  4503.   #define push_solution()  \
  4504.     { var reg1 object new_cons = allocate_cons(); \
  4505.       Car(new_cons) = *previous;                  \
  4506.       Cdr(new_cons) = *solutions;                 \
  4507.       *solutions = new_cons;                      \
  4508.     }
  4509.   #define push_solution_with(new_piece)  \
  4510.     { pushSTACK(new_piece);                                   \
  4511.      {var reg1 object new_cons = allocate_cons();             \
  4512.       Car(new_cons) = STACK_0; Cdr(new_cons) = *previous;     \
  4513.       STACK_0 = new_cons;                                     \
  4514.       new_cons = allocate_cons();                             \
  4515.       Car(new_cons) = popSTACK(); Cdr(new_cons) = *solutions; \
  4516.       *solutions = new_cons;                                  \
  4517.     }}
  4518.  
  4519. #if defined(PATHNAME_NOEXT) || defined(LOGICAL_PATHNAMES)
  4520.  
  4521.   local void wildcard_diff (object muster, object beispiel, object* previous, object* solutions);
  4522.  
  4523.   # rekursive Implementation wegen Backtracking:
  4524.   local void wildcard_diff_ab (object muster, object beispiel, uintL m_index, uintL b_index, object* previous, object* solutions);
  4525.  
  4526.   local void wildcard_diff(muster,beispiel,previous,solutions)
  4527.     var reg2 object muster;
  4528.     var reg1 object beispiel;
  4529.     var reg4 object* previous;
  4530.     var reg3 object* solutions;
  4531.     { wildcard_diff_ab(muster,beispiel,0,0,previous,solutions); }
  4532.  
  4533.   local void wildcard_diff_ab(muster,beispiel,m_index,b_index,previous,solutions)
  4534.     var reg3 object muster;
  4535.     var reg2 object beispiel;
  4536.     var reg6 uintL m_index;
  4537.     var reg5 uintL b_index;
  4538.     var reg8 object* previous;
  4539.     var reg7 object* solutions;
  4540.     { var reg4 uintB c;
  4541.       loop
  4542.         { if (m_index == TheSstring(muster)->length)
  4543.             { if (b_index == TheSstring(beispiel)->length)
  4544.                 { push_solution(); }
  4545.               return;
  4546.             }
  4547.           c = TheSstring(muster)->data[m_index++];
  4548.           if (c=='*') break;
  4549.           if (b_index == TheSstring(beispiel)->length) return;
  4550.           if (c=='?')
  4551.             { # wildcard_diff_ab() rekursiv aufrufen, mit erweitertem previous:
  4552.               c = TheSstring(beispiel)->data[b_index++];
  4553.               pushSTACK(muster); pushSTACK(beispiel);
  4554.               { var reg1 object new_string = allocate_string(1);
  4555.                 TheSstring(new_string)->data[0] = c;
  4556.                 pushSTACK(new_string);
  4557.               }
  4558.               { var reg1 object new_cons = allocate_cons();
  4559.                 Car(new_cons) = STACK_0; Cdr(new_cons) = *previous;
  4560.                 STACK_0 = new_cons; # (CONS ... previous)
  4561.               }
  4562.               wildcard_diff_ab(STACK_2,STACK_1,m_index,b_index,&STACK_0,solutions);
  4563.               skipSTACK(3);
  4564.               return;
  4565.             }
  4566.             else
  4567.             { if (!equal_pathchar(TheSstring(beispiel)->data[b_index++],c))
  4568.                 return;
  4569.             }
  4570.         }
  4571.      {var reg9 uintL b_start_index = b_index;
  4572.       loop
  4573.         { # Um weniger zu consen, die Fälle abfangen, wo wildcard_diff_ab()
  4574.           # gar nichts tut:
  4575.           if (m_index == TheSstring(muster)->length
  4576.               ? b_index == TheSstring(beispiel)->length
  4577.               : (c = TheSstring(muster)->data[m_index],
  4578.                  (c=='*') || (c=='?')
  4579.                  || (b_index < TheSstring(beispiel)->length
  4580.                      && equal_pathchar(TheSstring(beispiel)->data[b_index],c)
  4581.              )  )   )
  4582.             # wildcard_diff_ab() rekursiv aufrufen, mit erweitertem previous:
  4583.             { pushSTACK(muster); pushSTACK(beispiel);
  4584.               pushSTACK(beispiel); pushSTACK(fixnum(b_start_index)); pushSTACK(fixnum(b_index));
  4585.               funcall(L(substring),3); # (SUBSTRING beispiel b_start_index b_index)
  4586.               pushSTACK(value1);
  4587.              {var reg1 object new_cons = allocate_cons();
  4588.               Car(new_cons) = STACK_0; Cdr(new_cons) = *previous;
  4589.               STACK_0 = new_cons; # (CONS ... previous)
  4590.               wildcard_diff_ab(STACK_2,STACK_1,m_index,b_index,&STACK_0,solutions);
  4591.               skipSTACK(1);
  4592.               beispiel = popSTACK(); muster = popSTACK();
  4593.             }}
  4594.           if (b_index == TheSstring(beispiel)->length)
  4595.             break;
  4596.           b_index++;
  4597.         }
  4598.     }}
  4599.  
  4600. #endif
  4601.  
  4602. # UPs: Vergleicht jeweils eine Pathname-Komponente ("Beispiel") und
  4603. # eine Pathname-Komponente ("Muster").
  4604. # kann GC auslösen
  4605.   local void host_diff (object muster, object beispiel, boolean logical, object* previous, object* solutions);
  4606.   local void device_diff (object muster, object beispiel, boolean logical, object* previous, object* solutions);
  4607.   local void directory_diff (object muster, object beispiel, boolean logical, object* previous, object* solutions);
  4608.   local void nametype_diff (object muster, object beispiel, boolean logical, object* previous, object* solutions);
  4609.   local void version_diff (object muster, object beispiel, boolean logical, object* previous, object* solutions);
  4610.   local void host_diff(muster,beispiel,logical,previous,solutions)
  4611.     var reg2 object muster;
  4612.     var reg1 object beispiel;
  4613.     var reg5 boolean logical;
  4614.     var reg4 object* previous;
  4615.     var reg3 object* solutions;
  4616.     {
  4617.       #ifdef LOGICAL_PATHNAMES
  4618.       if (logical)
  4619.         { if (!equal(muster,beispiel)) return; }
  4620.         else
  4621.       #endif
  4622.         {
  4623.           #if HAS_HOST
  4624.           if (!equal(muster,beispiel)) return;
  4625.           #endif
  4626.         }
  4627.       push_solution();
  4628.     }
  4629.   local void device_diff(muster,beispiel,logical,previous,solutions)
  4630.     var reg2 object muster;
  4631.     var reg1 object beispiel;
  4632.     var reg5 boolean logical;
  4633.     var reg4 object* previous;
  4634.     var reg3 object* solutions;
  4635.     {
  4636.       #if HAS_DEVICE
  4637.       #ifdef LOGICAL_PATHNAMES
  4638.       if (logical)
  4639.         { push_solution(); return; }
  4640.       #endif
  4641.       #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  4642.       if (eq(muster,S(Kwild)))
  4643.         { var reg1 object string =
  4644.             (eq(beispiel,S(Kwild)) ? O(wild_string) :
  4645.              simple_string_p(beispiel) ? beispiel : O(leer_string)
  4646.             );
  4647.           push_solution_with(string);
  4648.           return;
  4649.         }
  4650.       if (eq(beispiel,S(Kwild))) return;
  4651.       #endif
  4652.       #if defined(PATHNAME_AMIGAOS) || defined(PATHNAME_OS2)
  4653.       if (!equalp(muster,beispiel)) return;
  4654.       #else
  4655.       if (!equal(muster,beispiel)) return;
  4656.       #endif
  4657.       #endif
  4658.       push_solution();
  4659.     }
  4660.   local void nametype_diff(muster,beispiel,logical,previous,solutions)
  4661.     var reg2 object muster;
  4662.     var reg1 object beispiel;
  4663.     var reg5 boolean logical;
  4664.     var reg4 object* previous;
  4665.     var reg3 object* solutions;
  4666.     {
  4667.       #ifdef LOGICAL_PATHNAMES
  4668.       if (logical)
  4669.         { if (eq(muster,S(Kwild)))
  4670.             { var reg1 object string =
  4671.                 (eq(beispiel,S(Kwild)) ? O(wild_string) :
  4672.                  simple_string_p(beispiel) ? beispiel : O(leer_string)
  4673.                 );
  4674.               push_solution_with(string);
  4675.               return;
  4676.             }
  4677.           if (eq(beispiel,S(Kwild))) return;
  4678.           if (nullp(muster))
  4679.             { if (nullp(beispiel))
  4680.                 { push_solution(); }
  4681.               return;
  4682.             }
  4683.           if (nullp(beispiel))
  4684.             return;
  4685.           wildcard_diff(muster,beispiel,previous,solutions);
  4686.           return;
  4687.         }
  4688.       #endif
  4689.       #ifdef PATHNAME_EXT83
  4690.       if (eq(muster,S(Kwild)))
  4691.         { var reg1 object string =
  4692.             (eq(beispiel,S(Kwild)) ? O(wild_string) :
  4693.              simple_string_p(beispiel) ? beispiel : O(leer_string)
  4694.             );
  4695.           push_solution_with(string);
  4696.           return;
  4697.         }
  4698.       if (eq(beispiel,S(Kwild))) return;
  4699.       if (!equal(muster,beispiel)) return;
  4700.       push_solution();
  4701.       #endif
  4702.       #ifdef PATHNAME_NOEXT
  4703.       if (nullp(muster))
  4704.         { if (nullp(beispiel))
  4705.             { push_solution(); }
  4706.           return;
  4707.         }
  4708.       if (nullp(beispiel))
  4709.         return;
  4710.       wildcard_diff(muster,beispiel,previous,solutions);
  4711.       #endif
  4712.     }
  4713.   local void subdir_diff(muster,beispiel,logical,previous,solutions)
  4714.     var reg2 object muster;
  4715.     var reg1 object beispiel;
  4716.     var reg5 boolean logical;
  4717.     var reg4 object* previous;
  4718.     var reg3 object* solutions;
  4719.     { if (eq(muster,beispiel))
  4720.         { if (eq(beispiel,S(Kwild)))
  4721.             { push_solution_with(O(wild_string)); }
  4722.             else
  4723.             { push_solution(); }
  4724.           return;
  4725.         }
  4726.       #ifdef LOGICAL_PATHNAMES
  4727.       if (logical)
  4728.         { if (eq(muster,S(Kwild)))
  4729.             { var reg1 object string =
  4730.                 (eq(beispiel,S(Kwild)) ? O(wild_string) :
  4731.                  simple_string_p(beispiel) ? beispiel : O(leer_string)
  4732.                 );
  4733.               push_solution_with(string);
  4734.               return;
  4735.             }
  4736.           if (eq(beispiel,S(Kwild))) return;
  4737.           if (!simple_string_p(muster) || !simple_string_p(beispiel)) return;
  4738.           wildcard_diff(muster,beispiel,previous,solutions);
  4739.           return;
  4740.         }
  4741.       #endif
  4742.       #ifdef PATHNAME_EXT83
  4743.       if (atomp(muster) || atomp(beispiel)) return;
  4744.       pushSTACK(NIL); pushSTACK(Cdr(muster)); pushSTACK(Cdr(beispiel));
  4745.       nametype_diff(Car(muster),Car(beispiel),FALSE,previous,&STACK_2);
  4746.       while (mconsp(STACK_2))
  4747.         { pushSTACK(Car(STACK_2));
  4748.           nametype_diff(STACK_(1+1),STACK_(0+1),FALSE,&STACK_0,solutions);
  4749.           skipSTACK(1);
  4750.           STACK_2 = Cdr(STACK_2);
  4751.         }
  4752.       skipSTACK(3);
  4753.       #endif
  4754.       #ifdef PATHNAME_NOEXT
  4755.       if (!simple_string_p(muster) || !simple_string_p(beispiel)) return;
  4756.       wildcard_diff(muster,beispiel,previous,solutions);
  4757.       #endif
  4758.     }
  4759.   # rekursive Implementation wegen Backtracking:
  4760.   local void directory_diff_ab (object m_list, object b_list, boolean logical, object* previous, object* solutions);
  4761.   local void directory_diff_ab(m_list,b_list,logical,previous,solutions)
  4762.     var reg3 object m_list;
  4763.     var reg2 object b_list;
  4764.     var reg8 boolean logical;
  4765.     var reg6 object* previous;
  4766.     var reg7 object* solutions;
  4767.     { # Algorithmus analog zu wildcard_diff_ab.
  4768.       var reg4 object item;
  4769.       if (atomp(m_list))
  4770.         { if (atomp(b_list))
  4771.             { push_solution(); }
  4772.           return;
  4773.         }
  4774.       item = Car(m_list); m_list = Cdr(m_list);
  4775.       if (!eq(item,S(Kwild_inferiors)))
  4776.         { if (atomp(b_list)) return;
  4777.           pushSTACK(NIL); pushSTACK(m_list); pushSTACK(Cdr(b_list));
  4778.           subdir_diff(item,Car(b_list),logical,previous,&STACK_2);
  4779.           # directory_diff_ab() rekursiv aufrufen, mit erweitertem previous:
  4780.           while (mconsp(STACK_2))
  4781.             { pushSTACK(Car(STACK_2));
  4782.               directory_diff_ab(STACK_(1+1),STACK_(0+1),logical,&STACK_0,solutions);
  4783.               skipSTACK(1);
  4784.               STACK_2 = Cdr(STACK_2);
  4785.             }
  4786.           skipSTACK(3);
  4787.         }
  4788.         else
  4789.         { pushSTACK(b_list); # b_start_list := b_list
  4790.           loop
  4791.             { # Um weniger zu consen, die Fälle abfangen, wo directory_diff_ab()
  4792.               # gar nichts tut:
  4793.               if (atomp(m_list)
  4794.                   ? atomp(b_list)
  4795.                   : (eq(Car(m_list),S(Kwild_inferiors)) || !atomp(b_list))
  4796.                  )
  4797.                 # directory_diff_ab() rekursiv aufrufen, mit erweitertem previous:
  4798.                 { pushSTACK(m_list); pushSTACK(b_list);
  4799.                   pushSTACK(STACK_2); pushSTACK(b_list);
  4800.                   funcall(L(ldiff),2); # (LDIFF b_start_list b_list)
  4801.                   pushSTACK(value1);
  4802.                  {var reg1 object new_cons = allocate_cons();
  4803.                   Car(new_cons) = STACK_0; Cdr(new_cons) = *previous;
  4804.                   STACK_0 = new_cons; # (CONS ... previous)
  4805.                   directory_diff_ab(STACK_2,STACK_1,logical,&STACK_0,solutions);
  4806.                   skipSTACK(1);
  4807.                   b_list = popSTACK(); m_list = popSTACK();
  4808.                 }}
  4809.               if (atomp(b_list)) break;
  4810.               b_list = Cdr(b_list);
  4811.             }
  4812.           skipSTACK(1);
  4813.         }
  4814.     }
  4815.   local void directory_diff(muster,beispiel,logical,previous,solutions)
  4816.     var reg2 object muster;
  4817.     var reg1 object beispiel;
  4818.     var reg5 boolean logical;
  4819.     var reg4 object* previous;
  4820.     var reg3 object* solutions;
  4821.     {
  4822.       # Startpoint vergleichen:
  4823.       if (!eq(Car(muster),Car(beispiel)))
  4824.         return;
  4825.       muster = Cdr(muster); beispiel = Cdr(beispiel);
  4826.       # subdirs vergleichen:
  4827.       directory_diff_ab(muster,beispiel,logical,previous,solutions);
  4828.     }
  4829.   local void version_diff(muster,beispiel,logical,previous,solutions)
  4830.     var reg2 object muster;
  4831.     var reg1 object beispiel;
  4832.     var reg5 boolean logical;
  4833.     var reg4 object* previous;
  4834.     var reg3 object* solutions;
  4835.     {
  4836.       #ifdef LOGICAL_PATHNAMES
  4837.       if (logical)
  4838.         { if (eq(muster,S(Kwild)))
  4839.             { var reg1 object string =
  4840.                 (eq(beispiel,S(Kwild)) ? O(wild_string) :
  4841.                  integerp(beispiel) ? (pushSTACK(beispiel), C_decimal_string(), value1) : # (SYS::DECIMAL-STRING beispiel)
  4842.                  O(leer_string)
  4843.                 );
  4844.               push_solution_with(string);
  4845.               return;
  4846.             }
  4847.           if (eq(beispiel,S(Kwild))) return;
  4848.           if (!eql(muster,beispiel)) return;
  4849.           push_solution();
  4850.           return;
  4851.         }
  4852.       #endif
  4853.       #if HAS_VERSION
  4854.       if (eq(muster,S(Kwild)))
  4855.         { var reg1 object string =
  4856.             (eq(beispiel,S(Kwild)) ? O(wild_string) :
  4857.              integerp(beispiel) ? (pushSTACK(beispiel), C_decimal_string(), value1) : # (SYS::DECIMAL-STRING beispiel)
  4858.              O(leer_string)
  4859.             );
  4860.           push_solution_with(string);
  4861.           return;
  4862.         }
  4863.       if (eq(beispiel,S(Kwild))) return;
  4864.       if (!eql(muster,beispiel)) return;
  4865.       #endif
  4866.       push_solution();
  4867.     }
  4868.  
  4869.   #undef push_solution_with
  4870.   #undef push_solution
  4871.  
  4872. # Jede Substitution ist eine Liste von Simple-Strings oder Listen.
  4873. # (Die Listen entstehen bei :WILD-INFERIORS in directory_diff().)
  4874. # Ein Simple-String paßt nur auf '?' oder '*' oder :WILD,
  4875. # eine Liste paßt nur auf :WILD-INFERIORS.
  4876.  
  4877. #ifdef LOGICAL_PATHNAMES
  4878.  
  4879. # Beim Einsetzen von Stücken normaler Pathnames in logische Pathnames:
  4880. # Umwandlung in Großbuchstaben.
  4881. # logical_case(string)
  4882. # > string: Simple-String oder Symbol/Zahl
  4883. # < ergebnis: umgewandelter Simple-String oder dasselbe Symbol/Zahl
  4884. # kann GC auslösen
  4885.   local object logical_case (object string);
  4886. # Dasselbe, rekursiv wie mit SUBST:
  4887.   local object subst_logical_case (object obj);
  4888. #if defined(PATHNAME_MSDOS)
  4889.   # sowieso schon alles Großbuchstaben
  4890.   #define logical_case(string)  string
  4891.   #define subst_logical_case(obj)  obj
  4892. #else
  4893.   local object logical_case(string)
  4894.     var reg1 object string;
  4895.     { if (!simple_string_p(string))
  4896.         return string;
  4897.       return string_upcase(string);
  4898.     }
  4899.   local object subst_logical_case(obj)
  4900.     var reg1 object obj;
  4901.     { if (atomp(obj))
  4902.         { return logical_case(obj); }
  4903.       check_STACK(); check_SP();
  4904.       pushSTACK(obj);
  4905.       # rekursiv für den CAR aufrufen:
  4906.       { var reg2 object new_car = subst_logical_case(Car(obj));
  4907.         pushSTACK(new_car);
  4908.       }
  4909.       # rekursiv für den CDR aufrufen:
  4910.       { var reg2 object new_cdr = subst_logical_case(Cdr(STACK_1));
  4911.         if (eq(new_cdr,Cdr(STACK_1)) && eq(STACK_0,Car(STACK_1)))
  4912.           { obj = STACK_1; skipSTACK(2); return obj; }
  4913.           else
  4914.           # (CONS new_car new_cdr)
  4915.           { STACK_1 = new_cdr;
  4916.            {var reg1 object new_cons = allocate_cons();
  4917.             Car(new_cons) = popSTACK(); Cdr(new_cons) = popSTACK();
  4918.             return new_cons;
  4919.     } }   }}
  4920. #endif
  4921.  
  4922. # Beim Einsetzen von Stücken logischer Pathnames in normale Pathnames:
  4923. # Umwandlung in Großbuchstaben.
  4924. # logical_case(string)
  4925. # > string: Simple-String oder Symbol/Zahl
  4926. # < ergebnis: umgewandelter Simple-String oder dasselbe Symbol/Zahl
  4927. # kann GC auslösen
  4928.   local object customary_case (object string);
  4929. # Dasselbe, rekursiv wie mit SUBST:
  4930.   local object subst_customary_case (object obj);
  4931. #if defined(PATHNAME_MSDOS)
  4932.   # Betriebssystem mit Vorzug für Großbuchstaben
  4933.   #define customary_case(string)  string
  4934.   #define subst_customary_case(obj)  obj
  4935. #else
  4936.   local object customary_case(string)
  4937.     var reg1 object string;
  4938.     { if (!simple_string_p(string))
  4939.         return string;
  4940.       #if defined(PATHNAME_UNIX) || defined(PATHNAME_OS2) || defined(PATHNAME_RISCOS)
  4941.       # Betriebssystem mit Vorzug für Kleinbuchstaben
  4942.       return string_downcase(string);
  4943.       #endif
  4944.       #ifdef PATHNAME_AMIGAOS
  4945.       # Betriebssystem mit Vorzug für Capitalize
  4946.       string = copy_string(string);
  4947.       nstring_capitalize(&TheSstring(string)->data[0],TheSstring(string)->length);
  4948.       return string;
  4949.       #endif
  4950.     }
  4951.   local object subst_customary_case(obj)
  4952.     var reg1 object obj;
  4953.     { if (atomp(obj))
  4954.         { return customary_case(obj); }
  4955.       check_STACK(); check_SP();
  4956.       pushSTACK(obj);
  4957.       # rekursiv für den CAR aufrufen:
  4958.       { var reg2 object new_car = subst_customary_case(Car(obj));
  4959.         pushSTACK(new_car);
  4960.       }
  4961.       # rekursiv für den CDR aufrufen:
  4962.       { var reg2 object new_cdr = subst_customary_case(Cdr(STACK_1));
  4963.         if (eq(new_cdr,Cdr(STACK_1)) && eq(STACK_0,Car(STACK_1)))
  4964.           { obj = STACK_1; skipSTACK(2); return obj; }
  4965.           else
  4966.           # (CONS new_car new_cdr)
  4967.           { STACK_1 = new_cdr;
  4968.            {var reg1 object new_cons = allocate_cons();
  4969.             Car(new_cons) = popSTACK(); Cdr(new_cons) = popSTACK();
  4970.             return new_cons;
  4971.     } }   }}
  4972. #endif
  4973.  
  4974. #endif
  4975.  
  4976. # UP: Eine Substitution auf ein Muster anwenden.
  4977. # translate_pathname(&subst,muster)
  4978.   local object translate_pathname (object* subst, object muster, boolean for_logical_p);
  4979. # translate_host(&subst,muster,logical) etc. liefert den host etc. mit Ersetzungen
  4980. # und verkürzen subst passend. Falls nicht passend, liefert es nullobj.
  4981.   local object translate_host (object* subst, object muster, boolean logical);
  4982.   local object translate_device (object* subst, object muster, boolean logical);
  4983.   local object convert_subdir (object muster, boolean for_logical_p);
  4984.   local object translate_subdir (object* subst, object muster, boolean logical, boolean for_logical_p);
  4985.   local object translate_directory (object* subst, object muster, boolean logical, boolean for_logical_p);
  4986.   local object translate_nametype (object* subst, object muster, boolean logical);
  4987.   local object translate_version (object* subst, object muster, boolean logical);
  4988.   #define translate_host(subst,muster,logical)  (muster)
  4989.   local object translate_device(subst,muster,logical)
  4990.     var reg1 object* subst;
  4991.     var reg2 object muster;
  4992.     var reg4 boolean logical;
  4993.     {
  4994.       #if HAS_DEVICE
  4995.       #ifdef LOGICAL_PATHNAMES
  4996.       if (logical)
  4997.         { return muster; }
  4998.       #endif
  4999.       if (eq(muster,S(Kwild)) && mconsp(*subst))
  5000.         { if (m_simple_string_p(Car(*subst)))
  5001.             { var reg3 object erg = Car(*subst); *subst = Cdr(*subst);
  5002.               return erg;
  5003.             }
  5004.             else
  5005.             return nullobj;
  5006.         }
  5007.       #endif
  5008.       return muster;
  5009.     }
  5010.   local object translate_nametype(subst,muster,logical)
  5011.     var reg6 object* subst;
  5012.     var reg3 object muster;
  5013.     var reg7 boolean logical;
  5014.     { if (eq(muster,S(Kwild)) && mconsp(*subst))
  5015.         { if (m_simple_string_p(Car(*subst)))
  5016.             { var reg3 object erg = Car(*subst); *subst = Cdr(*subst);
  5017.               return erg;
  5018.             }
  5019.             else
  5020.             return nullobj;
  5021.         }
  5022.       if (simple_string_p(muster))
  5023.         { pushSTACK(muster); # muster retten
  5024.          {var reg5 object* muster_ = &STACK_0;
  5025.           var reg4 uintL len = TheSstring(muster)->length;
  5026.           var reg1 uintL index = 0;
  5027.           var reg7 uintL stringcount = 0; # Anzahl der Strings auf dem Stack
  5028.           loop
  5029.             { var reg9 uintL last_index = index;
  5030.               var reg2 uintB c;
  5031.               # Suche nächstes Wildcard-Zeichen:
  5032.               muster = *muster_;
  5033.               loop
  5034.                 { if (index == len) break;
  5035.                   c = TheSstring(muster)->data[index];
  5036.                   if (((c=='*') # Wildcard für beliebig viele Zeichen
  5037.                        || (!logical && singlewild_char_p(c)) # Wildcard für genau ein Zeichen
  5038.                       )
  5039.                       && mconsp(*subst)
  5040.                      )
  5041.                     break;
  5042.                   index++;
  5043.                 }
  5044.               # Nächsten Teilstring auf den Stack:
  5045.               pushSTACK(muster); pushSTACK(fixnum(last_index)); pushSTACK(fixnum(index));
  5046.               funcall(L(substring),3); # (SUBSTRING muster last_index index)
  5047.               pushSTACK(value1); stringcount++;
  5048.               # Fertig?
  5049.               if (index == len) break;
  5050.               # Wildcard ersetzen:
  5051.               if (m_simple_string_p(Car(*subst)))
  5052.                 { pushSTACK(Car(*subst)); *subst = Cdr(*subst); stringcount++; }
  5053.                 else
  5054.                 { skipSTACK(stringcount+1); return nullobj; }
  5055.               index++;
  5056.             }
  5057.           funcall(L(string_concat),stringcount); # (STRING-CONCAT alle Strings)
  5058.           skipSTACK(1);
  5059.           return value1;
  5060.         }}
  5061.       return muster;
  5062.     }
  5063.  
  5064.   # kann GC auslösen
  5065.   local object convert_subdir (object muster, boolean for_logical_p);
  5066.   local object convert_subdir(muster,for_logical_p)
  5067.     var reg2 object muster; 
  5068.     var reg3 boolean for_logical_p;
  5069.     {
  5070.       #ifdef PATHNAME_EXT83
  5071.       if (for_logical_p)
  5072.         { pushSTACK(muster);
  5073.           muster = allocate_cons();
  5074.           Car(muster) = popSTACK();
  5075.           Cdr(muster) = O(leer_string);
  5076.         }
  5077.       #endif
  5078.       return muster;
  5079.     }
  5080.  
  5081.   local object translate_subdir(subst,muster,logical,for_logical_p)
  5082.     var reg3 object* subst;
  5083.     var reg2 object muster;
  5084.     var reg4 boolean logical;
  5085.     var reg5 boolean for_logical_p;
  5086.     {
  5087.       #ifdef LOGICAL_PATHNAMES
  5088.       if (logical)
  5089.         { return translate_nametype(subst,muster,logical); }
  5090.       #endif
  5091.       #ifdef PATHNAME_EXT83
  5092.       if (atomp(muster) && !for_logical_p) return muster;
  5093.       muster = convert_subdir(muster,for_logical_p);
  5094.       pushSTACK(Car(muster)); pushSTACK(Cdr(muster));
  5095.       if (eq(STACK_1 = translate_nametype(subst,STACK_1,FALSE),nullobj)
  5096.           || eq(STACK_0 = translate_nametype(subst,STACK_0,FALSE),nullobj)
  5097.          )
  5098.         { skipSTACK(2); return nullobj; }
  5099.       {var reg1 object new_cons = allocate_cons();
  5100.        Car(new_cons) = STACK_1; Cdr(new_cons) = STACK_0; skipSTACK(2);
  5101.        return new_cons;
  5102.       }
  5103.       #endif
  5104.       #ifdef PATHNAME_NOEXT
  5105.       return translate_nametype(subst,muster,FALSE);
  5106.       #endif
  5107.     }
  5108.   local object translate_directory(subst,muster,logical,for_logical_p)
  5109.     var reg2 object* subst;
  5110.     var reg4 object muster;
  5111.     var reg6 boolean logical;
  5112.     var reg7 boolean for_logical_p;
  5113.     { var reg5 uintL itemcount = 0; # Anzahl der Elemente auf dem Stack
  5114.       # Startpoint:
  5115.       pushSTACK(Car(muster)); muster = Cdr(muster); itemcount++;
  5116.       # subdirs:
  5117.       while (consp(muster))
  5118.         { var reg3 object item = Car(muster);
  5119.           muster = Cdr(muster);
  5120.           if (eq(item,S(Kwild_inferiors)))
  5121.             { if (mconsp(*subst))
  5122.                 { if (listp(Car(*subst)))
  5123.                     { var reg1 object list = Car(*subst); *subst = Cdr(*subst);
  5124.                       while (consp(list))
  5125.                         { var reg1 object obj;
  5126.                           pushSTACK(list);
  5127.                           pushSTACK(muster);
  5128.                           obj = convert_subdir(Car(list),for_logical_p);
  5129.                           muster = popSTACK();
  5130.                           list = popSTACK();
  5131.                           pushSTACK(obj);
  5132.                           list = Cdr(list);
  5133.                           itemcount++; 
  5134.                         }
  5135.                     }
  5136.                     else
  5137.                     { skipSTACK(itemcount); return nullobj; }
  5138.                 }
  5139.                 else
  5140.                 { 
  5141.                   pushSTACK(muster);
  5142.                   item = convert_subdir(item,for_logical_p); itemcount++; 
  5143.                   muster = popSTACK();
  5144.                   pushSTACK(item);
  5145.                 }
  5146.             }
  5147.             else
  5148.             { pushSTACK(muster); # muster retten
  5149.               item = translate_subdir(subst,item,logical,for_logical_p);
  5150.               if (eq(item,nullobj)) { skipSTACK(itemcount+1); return nullobj; }
  5151.               muster = STACK_0; STACK_0 = item; itemcount++;
  5152.             }
  5153.         }
  5154.       return listof(itemcount);
  5155.     }
  5156.   local object translate_version(subst,muster,logical)
  5157.     var reg1 object* subst;
  5158.     var reg2 object muster;
  5159.     var reg4 boolean logical;
  5160.     {
  5161.       #ifdef LOGICAL_PATHNAMES
  5162.       if (logical)
  5163.         { if (eq(muster,S(Kwild)) && mconsp(*subst))
  5164.             { if (m_simple_string_p(Car(*subst)))
  5165.                 { var reg3 object erg = Car(*subst); *subst = Cdr(*subst);
  5166.                   pushSTACK(erg); funcall(L(parse_integer),1);
  5167.                   return value1;
  5168.                 }
  5169.                 else
  5170.                 return nullobj;
  5171.             }
  5172.           return muster;
  5173.         }
  5174.       #endif
  5175.       #if HAS_VERSION
  5176.       if (eq(muster,S(Kwild)) && mconsp(*subst))
  5177.         { if (m_simple_string_p(Car(*subst)))
  5178.             { var reg3 object erg = Car(*subst); *subst = Cdr(*subst);
  5179.               pushSTACK(erg); funcall(L(parse_integer),1);
  5180.               return value1;
  5181.             }
  5182.             else
  5183.             return nullobj;
  5184.         }
  5185.       #endif
  5186.       return muster;
  5187.     }
  5188.   local object translate_pathname(subst,muster,for_logical_p)
  5189.     var reg2 object* subst;
  5190.     var reg3 object muster;
  5191.     var reg4 boolean for_logical_p;
  5192.     { var reg4 boolean logical = FALSE;
  5193.       var reg1 object item;
  5194.       pushSTACK(*subst); # subst retten für Fehlermeldung
  5195.       pushSTACK(muster);
  5196.       #ifdef LOGICAL_PATHNAMES
  5197.       if (logpathnamep(muster)) { logical = TRUE; }
  5198.       #endif
  5199.       # Argumente für MAKE-PATHNAME zusammenbauen:
  5200.       #if 1 # HAS_HOST || defined(LOGICAL_PATHNAMES)
  5201.       item = translate_host(subst,xpathname_host(logical,muster),logical);
  5202.       if (eq(item,nullobj)) { goto subst_error; }
  5203.       pushSTACK(S(Khost)); pushSTACK(item);
  5204.       #endif
  5205.       #if HAS_DEVICE
  5206.       item = translate_device(subst,xpathname_device(logical,STACK_2),logical);
  5207.       if (eq(item,nullobj)) { skipSTACK(2); goto subst_error; }
  5208.       pushSTACK(S(Kdevice)); pushSTACK(item);
  5209.       #endif
  5210.       item = translate_directory(subst,xpathname_directory(logical,STACK_(2+2*HAS_DEVICE)),logical,for_logical_p);
  5211.       if (eq(item,nullobj)) { skipSTACK(2+2*HAS_DEVICE); goto subst_error; }
  5212.       pushSTACK(S(Kdirectory)); pushSTACK(item);
  5213.       item = translate_nametype(subst,xpathname_name(logical,STACK_(2+2*HAS_DEVICE+2)),logical);
  5214.       if (eq(item,nullobj)) { skipSTACK(2+2*HAS_DEVICE+2); goto subst_error; }
  5215.       pushSTACK(S(Kname)); pushSTACK(item);
  5216.       item = translate_nametype(subst,xpathname_type(logical,STACK_(2+2*HAS_DEVICE+4)),logical);
  5217.       if (eq(item,nullobj)) { skipSTACK(2+2*HAS_DEVICE+4); goto subst_error; }
  5218.       pushSTACK(S(Ktype)); pushSTACK(item);
  5219.       #if 1 # HAS_VERSION || defined(LOGICAL_PATHNAMES)
  5220.       item = translate_version(subst,xpathname_version(logical,STACK_(2+2*HAS_DEVICE+6)),logical);
  5221.       if (eq(item,nullobj)) { skipSTACK(2+2*HAS_DEVICE+6); goto subst_error; }
  5222.       pushSTACK(S(Kversion)); pushSTACK(item);
  5223.       #endif
  5224.       # Alle Ersetzungsstücke müssen verbraucht werden!
  5225.       if (mconsp(*subst)) { skipSTACK(2+2*HAS_DEVICE+8); goto subst_error; }
  5226.       # (MAKE-PATHNAME ...) bzw. (SYS::MAKE-LOGICAL-PATHNAME ...) aufrufen:
  5227.       #ifdef LOGICAL_PATHNAMES
  5228.       if (logical)
  5229.         funcall(L(make_logical_pathname),2+2*HAS_DEVICE+8);
  5230.         else
  5231.       #endif
  5232.         funcall(L(make_pathname),2+2*HAS_DEVICE+8);
  5233.       skipSTACK(2);
  5234.       return value1;
  5235.      subst_error: # Error wegen nullobj.
  5236.       # Stackaufbau: subst, muster.
  5237.       pushSTACK(STACK_1);
  5238.       pushSTACK(S(translate_pathname));
  5239.       //: DEUTSCH "~: Ersetzungsstücke ~ passen nicht in ~."
  5240.       //: ENGLISH "~: replacement pieces ~ do not fit into ~"
  5241.       //: FRANCAIS "~ : Les pièces ~ ne vont pas dans ~."
  5242.       fehler(error, GETTEXT("~: replacement pieces ~ do not fit into ~"));
  5243.     }
  5244.  
  5245. LISPFUN(translate_pathname,3,0,norest,key,2, (kw(all),kw(merge)))
  5246. # (TRANSLATE-PATHNAME beispiel muster1 muster2 [:all] [:merge]), CLtL2 S. 624
  5247. # :all = T --> liefere eine Liste aller passenden Pathnames
  5248. # :all = NIL --> Error, falls mehr als ein Pathname paßt
  5249. # :merge = NIL --> letzten MERGE-PATHNAMES Schritt überspringen
  5250.   { # Stackaufbau: beispiel, muster1, muster2, all, merge.
  5251.     var reg3 boolean logical = FALSE; # Flag, ob beispiel und muster logische Pathnames sind
  5252.     var reg4 boolean logical2 = FALSE; # Flag, ob muster2 ein logischer Pathname ist
  5253.     var reg5 boolean logical1 = FALSE;
  5254.     STACK_4 = coerce_xpathname(STACK_4);
  5255.     STACK_3 = coerce_xpathname(STACK_3);
  5256.     STACK_2 = coerce_xpathname(STACK_2);
  5257.     #ifdef LOGICAL_PATHNAMES
  5258.     if (logpathnamep(STACK_4)) logical1 = TRUE;
  5259.     if (logpathnamep(STACK_4) && logpathnamep(STACK_3))
  5260.       { logical = TRUE; }
  5261.       else
  5262.       # nicht beides logische Pathnames -> erst in normale Pathnames umwandeln:
  5263.       { STACK_4 = coerce_pathname(STACK_4);
  5264.         STACK_3 = coerce_pathname(STACK_3);
  5265.       }
  5266.     if (logpathnamep(STACK_2))
  5267.       { logical2 = TRUE; }
  5268.     #endif
  5269.     # 1. Schritt: Liste aller passenden Substitutionen bilden.
  5270.     pushSTACK(NIL); pushSTACK(NIL);
  5271.     host_diff(xpathname_host(logical,STACK_(3+2)),xpathname_host(logical,STACK_(4+2)),logical,&STACK_1,&STACK_0);
  5272.     while (mconsp(STACK_0))
  5273.       { pushSTACK(Car(STACK_0)); pushSTACK(NIL);
  5274.         device_diff(xpathname_device(logical,STACK_(3+4)),xpathname_device(logical,STACK_(4+4)),logical,&STACK_1,&STACK_0);
  5275.         while (mconsp(STACK_0))
  5276.           { pushSTACK(Car(STACK_0)); pushSTACK(NIL);
  5277.             directory_diff(xpathname_directory(logical,STACK_(3+6)),xpathname_directory(logical,STACK_(4+6)),logical,&STACK_1,&STACK_0);
  5278.             while (mconsp(STACK_0))
  5279.               { pushSTACK(Car(STACK_0)); pushSTACK(NIL);
  5280.                 nametype_diff(xpathname_name(logical,STACK_(3+8)),xpathname_name(logical,STACK_(4+8)),logical,&STACK_1,&STACK_0);
  5281.                 while (mconsp(STACK_0))
  5282.                   { pushSTACK(Car(STACK_0)); pushSTACK(NIL);
  5283.                     nametype_diff(xpathname_type(logical,STACK_(3+10)),xpathname_type(logical,STACK_(4+10)),logical,&STACK_1,&STACK_0);
  5284.                     while (mconsp(STACK_0))
  5285.                       { pushSTACK(Car(STACK_0));
  5286.                         version_diff(xpathname_version(logical,STACK_(3+11)),xpathname_version(logical,STACK_(4+11)),logical,&STACK_0,&STACK_10);
  5287.                         skipSTACK(1);
  5288.                         STACK_0 = Cdr(STACK_0);
  5289.                       }
  5290.                     skipSTACK(2);
  5291.                     STACK_0 = Cdr(STACK_0);
  5292.                   }
  5293.                 skipSTACK(2);
  5294.                 STACK_0 = Cdr(STACK_0);
  5295.               }
  5296.             skipSTACK(2);
  5297.             STACK_0 = Cdr(STACK_0);
  5298.           }
  5299.         skipSTACK(2);
  5300.         STACK_0 = Cdr(STACK_0);
  5301.       }
  5302.     skipSTACK(1);
  5303.     # Stackaufbau: ..., solutions.
  5304.     if (matomp(STACK_0))
  5305.       { pushSTACK(STACK_(3+1));
  5306.         pushSTACK(STACK_(4+1+1));
  5307.         pushSTACK(S(translate_pathname));
  5308.         //: DEUTSCH "~: ~ ist keine Spezialisierung von ~."
  5309.         //: ENGLISH "~: ~ is not a specialization of ~"
  5310.         //: FRANCAIS "~ : ~ ne spécialise pas ~."
  5311.         fehler(error, GETTEXT("~: ~ is not a specialization of ~"));
  5312.       }
  5313.     # 2.,3. Schritt:
  5314.     pushSTACK(NIL); # pathnames := '()
  5315.     while (mconsp(STACK_1)) # solutions durchgehen
  5316.       { var reg1 object solutions = STACK_1;
  5317.         STACK_1 = Cdr(solutions);
  5318.        {var reg2 object solution = reverse(Car(solutions)); # Liste solution umdrehen
  5319.         # 2. Schritt: Substitution in muster2 einfügen.
  5320.         #ifdef LOGICAL_PATHNAMES
  5321.         # Groß-/Kleinschreibung passend konvertieren:
  5322.         if (!logical)
  5323.           { if (logical2)
  5324.               { solution = subst_logical_case(solution); }
  5325.           }
  5326.           else
  5327.           { if (!logical2)
  5328.               { solution = subst_customary_case(solution); }
  5329.           }
  5330.         #endif
  5331.         pushSTACK(solution);
  5332.         STACK_0 = translate_pathname(&STACK_0,STACK_(2+1+2),logical1);
  5333.        }
  5334.         # 3. Schritt: (MERGE-PATHNAMES modifiziertes_muster2 beispiel :WILD T)
  5335.         if (!nullp(STACK_(0+1+2))) # :MERGE-Argument abfragen
  5336.           if (has_some_wildcards(STACK_0)) # evtl. ist MERGE-PATHNAMES unnötig
  5337.             { pushSTACK(STACK_(4+1+2)); pushSTACK(unbound);
  5338.               pushSTACK(S(Kwild)); pushSTACK(T);
  5339.               funcall(L(merge_pathnames),5);
  5340.               pushSTACK(value1);
  5341.             }
  5342.         # (PUSH pathname pathnames)
  5343.        {var reg1 object new_cons = allocate_cons();
  5344.         Car(new_cons) = popSTACK(); Cdr(new_cons) = STACK_0;
  5345.         STACK_0 = new_cons;
  5346.       }}
  5347.     # 4. Schritt: (DELETE-DUPLICATES pathnames :TEST #'EQUAL)
  5348.     pushSTACK(S(Ktest)); pushSTACK(L(equal));
  5349.     funcall(L(delete_duplicates),3);
  5350.     # Stackaufbau: ..., nil.
  5351.     if (eq(STACK_(1+1),unbound) || nullp(STACK_(1+1))) # :ALL-Argument abfragen
  5352.       { if (mconsp(Cdr(value1)))
  5353.           { pushSTACK(value1);
  5354.             pushSTACK(STACK_(2+2));
  5355.             pushSTACK(STACK_(3+3));
  5356.             pushSTACK(STACK_(4+4));
  5357.             pushSTACK(S(translate_pathname));
  5358.             //: DEUTSCH "(~ ~ ~ ~) ist nicht eindeutig: ~"
  5359.             //: ENGLISH "(~ ~ ~ ~) is ambiguous: ~"
  5360.             //: FRANCAIS "(~ ~ ~ ~) est ambigu: ~"
  5361.             fehler(error, GETTEXT("(~ ~ ~ ~) is ambiguous: ~"));
  5362.           }
  5363.         value1 = Car(value1);
  5364.       }
  5365.     mv_count=1;
  5366.     skipSTACK(5+1);
  5367.   }
  5368.  
  5369. # UP: Stellt fest, ob der Name eines Pathname =NIL ist.
  5370. # namenullp(pathname)
  5371. # > pathname: nicht-Logical Pathname
  5372.   # local boolean namenullp (object pathname);
  5373.   # local boolean namenullp(pathname)
  5374.   #   { return nullp(ThePathname(pathname)->pathname_name); }
  5375.   #define namenullp(path)  (nullp(ThePathname(path)->pathname_name))
  5376.  
  5377. # Fehler, wenn ein Directory nicht existiert
  5378. # > obj: Pathname oder (besser) fehlerhafte Komponente
  5379.   nonreturning_function(local, fehler_dir_not_exists, (object obj));
  5380.   local void fehler_dir_not_exists(obj)
  5381.     var reg1 object obj;
  5382.     { pushSTACK(obj); # Wert für Slot PATHNAME von FILE-ERROR
  5383.       pushSTACK(obj);
  5384.       //: DEUTSCH "Directory existiert nicht: ~"
  5385.       //: ENGLISH "nonexistent directory: ~"
  5386.       //: FRANCAIS "Le répertoire ~ n'existe pas."
  5387.       fehler(file_error, GETTEXT("nonexistent directory: ~"));
  5388.     }
  5389.  
  5390. # Fehler, wenn eine Datei bereits existiert
  5391. # > caller: Aufrufer (ein Symbol)
  5392. # > pathname: Pathname
  5393.   nonreturning_function(local, fehler_file_exists, (object caller, object pathname));
  5394.   local void fehler_file_exists(caller,pathname)
  5395.     var reg2 object caller;
  5396.     var reg1 object pathname;
  5397.     { pushSTACK(pathname); # Wert für Slot PATHNAME von FILE-ERROR
  5398.       pushSTACK(pathname);
  5399.       pushSTACK(caller);
  5400.       //: DEUTSCH "~: Eine Datei ~ existiert bereits."
  5401.       //: ENGLISH "~: File ~ already exists"
  5402.       //: FRANCAIS "~ : Le fichier ~ existe déjà."
  5403.       fehler(file_error, GETTEXT("~: File ~ already exists"));
  5404.     }
  5405.  
  5406. #ifdef LOGICAL_PATHNAMES
  5407. # Ein "absoluter Pathname" ist stets ein nicht-Logical Pathname, evtl.
  5408. # mit weiteren Einschränkungen.
  5409. #endif
  5410.  
  5411. #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  5412.  
  5413. # Ein "absoluter Pathname" ist ein Pathname, bei dem Device ein überprüfter
  5414. # String ist und Directory kein :RELATIVE, :CURRENT, :PARENT enthält.
  5415.  
  5416. # UP: Liefert den Namestring eines Pathname als ASCIZ-String.
  5417. # namestring_asciz(dir_namestring)
  5418. # > STACK_0: nicht-Logical Pathname
  5419. # > dir_namestring: Directory-Namestring (für DOS bzw. GEMDOS, ohne Seriennummer)
  5420. # < ergebnis: Namestring (für DOS bzw. GEMDOS, ohne Seriennummer, mit Nullbyte am Schluß)
  5421. # kann GC auslösen
  5422.   local object namestring_asciz (object dir_namestring);
  5423.   local object namestring_asciz(dir_namestring)
  5424.     var reg2 object dir_namestring;
  5425.     { var reg1 uintC stringcount;
  5426.       pushSTACK(dir_namestring); # Directory-Namestring als 1. String
  5427.       stringcount = file_namestring_parts(STACK_(0+1)); # Strings zum Filenamen
  5428.       pushSTACK(O(null_string)); # String mit Nullbyte
  5429.       return string_concat(1+stringcount+1); # zusammenhängen
  5430.     }
  5431.  
  5432. #if !(defined(WATCOM) && defined(WINDOWS))
  5433.  
  5434. # Working Directory auf einem gegebenen Drive abfragen:
  5435. # getwdof(&buf,drive)
  5436. # > uintB* &buf: Adresse eines Path-Buffers
  5437. # > uintB drive: Laufwerk (0=A, 1=B, ...)
  5438. # < ergebnis: <0 falls Fehler
  5439.   #ifdef DJUNIX
  5440.     #if DJGPP == 2
  5441.       local int getwdof (uintB* buf, uintB drive);
  5442.       local int getwdof(buf,drive)
  5443.         var uintB* buf;
  5444.         var uintB drive;
  5445.         { var char buf__[MAXPATHLEN+1];
  5446.           var reg1 uintB *buf_;
  5447.           var unsigned int current_drive;
  5448.           var unsigned int drive_count;
  5449.           _dos_getdrive(¤t_drive);
  5450.           _dos_setdrive(drive,&drive_count);
  5451.           getcwd(buf__,MAXPATHLEN);
  5452.           buf_=buf__+3;
  5453.           while (*buf_) { *buf++=*buf_++; }
  5454.           *buf='\0';
  5455.           _dos_setdrive(current_drive,&drive_count);
  5456.           return 0;
  5457.         }
  5458.     #else
  5459.       #define getwdof(buf,drive)  \
  5460.         ({__asm__ (# DOS Function 47H                                                         \
  5461.                    " movb $0x47,%%ah ; int $0x21 "                                            \
  5462.                    :                                                                # OUT     \
  5463.                    : "S" /* %esi */ ((uintB*)(buf)), "d" /* %dl */ ((uintB)(drive)) # IN      \
  5464.                    : "ax","bx","cx","di" /* %eax, %ebx, %ecx, %edi */               # CLOBBER \
  5465.                   );                                                                          \
  5466.           0;                                                                                  \
  5467.          })
  5468.     #endif
  5469.   #endif
  5470.   #ifdef EMUNIX
  5471.     #define getwdof(buf,drive)  _getcwd(buf,drive)
  5472.   #endif
  5473.   #ifdef WATCOM
  5474.     local int getwdof (uintB* buf, uintB drive);
  5475.     local int getwdof(buf,drive)
  5476.       var uintB* buf;
  5477.       var uintB drive;
  5478.       { var union REGS in;
  5479.         var union REGS out;
  5480.         in.regB.ah = 0x47; in.regB.dl = drive; in.regL.esi = (unsigned long) buf;
  5481.         intdos(&in,&out);
  5482.         return 0;
  5483.       }
  5484.   #endif
  5485.  
  5486. # Liefert das aktuelle Directory auf einem Laufwerk.
  5487. # getwd_of(path,drive)
  5488. # > uintB drive: Laufwerks-(groß-)buchstabe
  5489. # > uintB* path: Platz fürs aktuelle Directory
  5490. # < path: Pfad des aktuellen Directories, mit '/' als Trennzeichen und als Anfang
  5491. # < ergebnis: <0 falls Fehler
  5492.   #if defined(DJUNIX) || defined(WATCOM)
  5493.     #define getwd_of(path,drive)  ((path)[0] = '/', getwdof(&(path)[1],(drive)-'A'+1))
  5494.   #endif
  5495.   #ifdef EMUNIX
  5496.     #define getwd_of(path,drive)  _getcwd1(path,drive)
  5497.   #endif
  5498.  
  5499. #endif # !(WATCOM && WINDOWS)
  5500.  
  5501. # UP: Stellt fest, ob ein Laufwerk existiert.
  5502. # > uintB drive: Laufwerks-(groß-)buchstabe
  5503. # < boolean ergebnis: ob dieses Laufwerk existiert und ansprechbar ist
  5504.   local boolean good_drive (uintB drive);
  5505.   #ifdef EMUNIX
  5506.   local boolean good_drive(drive)
  5507.     var reg1 uintB drive;
  5508.     { # Methode (siehe HELPPC/misc.txt):
  5509.       # 1. save current drive  (INT 0x21,0x19)
  5510.       # 2. set current drive  (INT 0x21,0xE)
  5511.       # 3. get current drive  (INT 0x21,0x19)
  5512.       # 4. if current drive == drive requested
  5513.       #       then drive exists
  5514.       #       else drive doesn't exist
  5515.       # 5. reset original drive  (INT 0x21,0xE)
  5516.       var reg3 boolean result;
  5517.       begin_system_call();
  5518.      {var reg2 uintB orig_drive = _getdrive();
  5519.       _chdrive(drive);
  5520.       result = (_getdrive() == drive);
  5521.       _chdrive(orig_drive);
  5522.      }
  5523.       end_system_call();
  5524.       return result;
  5525.       # Alternative:
  5526.       # { var uintB drv[3];
  5527.       #   var uintB fsys[16];
  5528.       #   drv[0] = drive; drv[1] = ':'; drv[2] = '\0';
  5529.       #   begin_system_call();
  5530.       #  {var int result = _filesys(drv,&fsys,sizeof(fsys));
  5531.       #   end_system_call();
  5532.       #   return (result==0);
  5533.       # }}
  5534.     }
  5535.   #endif
  5536.   #if defined(DJUNIX) || defined(WATCOM)
  5537.   local boolean good_drive(drive)
  5538.     var reg1 uintB drive;
  5539.     { # Methode (siehe HELPPC/misc.txt):
  5540.       # 1. save current drive  (INT 0x21,0x19)
  5541.       # 2. set current drive  (INT 0x21,0xE)
  5542.       # 3. get current drive  (INT 0x21,0x19)
  5543.       # 4. if current drive == drive requested
  5544.       #       then drive exists
  5545.       #       else drive doesn't exist
  5546.       # 5. reset original drive  (INT 0x21,0xE)
  5547.       var union REGS in;
  5548.       var union REGS out;
  5549.       var reg2 uintB orig_drive;
  5550.       var reg3 boolean result;
  5551.       begin_system_call();
  5552.       in.regB.ah = 0x19; intdos(&in,&out); orig_drive = out.regB.al; # 1.
  5553.       in.regB.ah = 0x0E; in.regB.dl = drive; intdos(&in,&out);       # 2.
  5554.       in.regB.ah = 0x19; intdos(&in,&out);                           # 3.
  5555.       result = (out.regB.al == drive);                               # 4.
  5556.       in.regB.ah = 0x0E; in.regB.dl = orig_drive; intdos(&in,&out);  # 5.
  5557.       end_system_call();
  5558.       return result;
  5559.     }
  5560.   #endif
  5561.   #ifdef WIN32_DOS
  5562.   local boolean good_drive(drive)
  5563.     var reg1 uintB drive;
  5564.     { var char RootPathName[4];
  5565.       var reg2 boolean result;
  5566.       RootPathName[0]=drive;
  5567.       RootPathName[1]=':';
  5568.       RootPathName[2]='\\';
  5569.       RootPathName[3]='\0';
  5570.       begin_system_call();
  5571.       result = GetDriveType(RootPathName) > 0;
  5572.       end_system_call();
  5573.       return result;
  5574.     }
  5575.   #endif
  5576.  
  5577. # UP: Liefert das aktuelle Drive.
  5578. # < uintB drive: Laufwerks-(groß-)buchstabe
  5579.   local uintB default_drive (void);
  5580.  #ifdef EMUNIX
  5581.   local uintB default_drive()
  5582.     { var reg1 uintB result;
  5583.       begin_system_call();
  5584.       result = _getdrive();
  5585.       end_system_call();
  5586.       return result;
  5587.     }
  5588.  #endif
  5589.  #if defined(DJUNIX) || defined(WATCOM)
  5590.   #if 1
  5591.     local uintB default_drive()
  5592.       { var union REGS in;
  5593.         var union REGS out;
  5594.         begin_system_call();
  5595.         in.regB.ah = 0x19;
  5596.         intdos(&in,&out);
  5597.         end_system_call();
  5598.         return 'A'+out.regB.al;
  5599.       }
  5600.   #else # nur defined(WATCOM)
  5601.     local uintB default_drive()
  5602.       { var unsigned int drive;
  5603.         begin_system_call();
  5604.         _dos_getdrive(&drive);
  5605.         end_system_call();
  5606.         return 'A'+drive-1;
  5607.       }
  5608.   #endif
  5609.  #endif
  5610.  #ifdef WIN32_DOS
  5611.    local uintB default_drive()
  5612.     { var char path_buffer[3+MAXPATHLEN]; # vgl. GETWD(3)
  5613.       begin_system_call();
  5614.       GetCurrentDirectory (MAXPATHLEN,path_buffer);
  5615.       end_system_call();
  5616.       return path_buffer[0];
  5617.     }
  5618.  #endif
  5619.  
  5620. # UP: Liefert das aktuelle Directory auf einem gegebenen Drive.
  5621. # > uintB drive: Laufwerks-(groß-)buchstabe
  5622. # < ergebnis: aktuelles Directory (als Pathname)
  5623. # kann GC auslösen
  5624.   local object default_directory_of (uintB drive);
  5625.   local object default_directory_of(drive)
  5626.     var reg1 uintB drive;
  5627.     # Working Directory (von DOS) ist das aktuelle Directory:
  5628.     { var char path_buffer[3+MAXPATHLEN]; # vgl. GETWD(3)
  5629.       #if !(defined(WATCOM) && defined(WINDOWS)) && !defined(WIN32_DOS)
  5630.         path_buffer[0] = drive; path_buffer[1] = ':';
  5631.         # Working Directory in path_buffer ablegen:
  5632.         begin_system_call();
  5633.         getwd_of(&path_buffer[2],drive);
  5634.         end_system_call();
  5635.       #elif defined(WIN32_DOS)
  5636.         begin_system_call();
  5637.         GetCurrentDirectory (MAXPATHLEN,path_buffer);
  5638.         end_system_call();
  5639.       #else # defined(WATCOM) && defined(WINDOWS)
  5640.         # Methode:
  5641.         # 1. save current drive  (INT 0x21,0x19)
  5642.         # 2. set current drive  (INT 0x21,0xE)
  5643.         # 3. get current directory on current drive  (getcwd)
  5644.         # 4. reset original drive  (INT 0x21,0xE)
  5645.         { var union REGS in;
  5646.           var union REGS out;
  5647.           var reg2 uintB orig_drive;
  5648.           begin_system_call();
  5649.           in.regB.ah = 0x19; intdos(&in,&out); orig_drive = out.regB.al; # 1.
  5650.           in.regB.ah = 0x0E; in.regB.dl = drive-'A'+1; intdos(&in,&out); # 2.
  5651.           getcwd(&path_buffer[0],sizeof(path_buffer));                   # 3.
  5652.           in.regB.ah = 0x0E; in.regB.dl = orig_drive; intdos(&in,&out);  # 4.
  5653.           end_system_call();
  5654.         }
  5655.         ASSERT(path_buffer[0]==drive);
  5656.         ASSERT(path_buffer[1]==':');
  5657.         ASSERT(path_buffer[2]=='\\');
  5658.         # evtl. noch ein '\' am Schluß anfügen:
  5659.         { var reg2 char* path_end = &path_buffer[asciz_length(path_buffer)];
  5660.           if (!(path_end[-1]=='\\')) { path_end[0] = '\\'; path_end[1] = '\0'; }
  5661.         }
  5662.       #endif
  5663.       # Hack von DJ (siehe GO32/EXPHDLR.C) und EM (siehe LIB/MISC/_GETCWD1.C):
  5664.       # wandelt alle '\' in '/' und alle Groß- in Kleinbuchstaben (nur Kosmetik,
  5665.       # da DOS und unser PARSE-NAMESTRING auch Filenamen mit '/' statt '\'
  5666.       # verstehen).
  5667.       # in Pathname umwandeln:
  5668.       return asciz_dir_to_pathname(&path_buffer[0]);
  5669.     }
  5670.  
  5671. # UP: Füllt Default-Drive und Default-Directory in einen Pathname ein.
  5672. # use_default_dir(pathname)
  5673. # > pathname: nicht-Logical Pathname mit Device /= :WILD
  5674. # < ergebnis: neuer absoluter Pathname
  5675. # kann GC auslösen
  5676.   local object use_default_dir (object pathname);
  5677.   local object use_default_dir(pathname)
  5678.     var reg4 object pathname;
  5679.     { # erst den Pathname kopieren:
  5680.       pathname = copy_pathname(pathname);
  5681.       pushSTACK(pathname);
  5682.       # Stackaufbau: pathname.
  5683.       # Default fürs Device:
  5684.       if (nullp(ThePathname(pathname)->pathname_device)) # kein Device angegeben?
  5685.         # Nimm das Default-Drive stattdessen:
  5686.         { ThePathname(pathname)->pathname_device = O(default_drive); }
  5687.       # Default fürs Directory:
  5688.         { var reg3 object subdirs = ThePathname(pathname)->pathname_directory;
  5689.           # Fängt pathname-directory mit :RELATIVE an?
  5690.           if (eq(Car(subdirs),S(Krelative)))
  5691.             # ja -> Ersetze :RELATIVE durch das Default-Directory:
  5692.             { var reg5 uintB drive = TheSstring(ThePathname(pathname)->pathname_device)->data[0];
  5693.               var reg2 object default_dir = default_directory_of(drive);
  5694.               # default_dir (ein Pathname) ist fertig.
  5695.               # Ersetze :RELATIVE durch default-subdirs, d.h.
  5696.               # bilde  (append default-subdirs (cdr subdirs))
  5697.               #      = (nreconc (reverse default-subdirs) (cdr subdirs))
  5698.               pushSTACK(Cdr(subdirs));
  5699.              {var reg1 object temp = ThePathname(default_dir)->pathname_directory;
  5700.               temp = reverse(temp);
  5701.               subdirs = nreconc(temp,popSTACK());
  5702.             }}
  5703.           # Liste durchgehen und dabei neu aufconsen, dabei '.\' und '..\'
  5704.           # und '...\' verarbeiten (nicht dem DOS bzw. GEMDOS überlassen):
  5705.           pushSTACK(subdirs);
  5706.           pushSTACK(NIL);
  5707.           # Stackaufbau: Pathname, subdir-oldlist, subdir-newlist.
  5708.           while (mconsp(STACK_1)) # Bis oldlist am Ende ist:
  5709.             { var reg2 object subdir = Car(STACK_1); # nächstes subdir
  5710.               if
  5711.                  #if defined(PATHNAME_MSDOS)
  5712.                  (eq(subdir,S(Kcurrent)))
  5713.                  #else
  5714.                  (equal(subdir,O(punkt_string)))
  5715.                  #endif
  5716.                 # = :CURRENT -> newlist unverändert lassen
  5717.                 {}
  5718.               elif
  5719.                    #if defined(PATHNAME_MSDOS)
  5720.                    (eq(subdir,S(Kparent)))
  5721.                    #else
  5722.                    (equal(subdir,O(punktpunkt_string)))
  5723.                    #endif
  5724.                 # = :PARENT -> newlist um eins verkürzen:
  5725.                 { if (matomp(Cdr(STACK_0))) # newlist (bis auf :ABSOLUTE) leer ?
  5726.                     { # :PARENT von "\" aus liefert Error
  5727.                       pushSTACK(STACK_2); # Wert für Slot PATHNAME von FILE-ERROR
  5728.                       pushSTACK(O(backslash_string)); # "\\"
  5729.                       pushSTACK(directory_namestring(STACK_(2+2))); # Directory von pathname
  5730.                       //: DEUTSCH "Directory ~ oberhalb ~ existiert nicht."
  5731.                       //: ENGLISH "no directory ~ above ~"
  5732.                       //: FRANCAIS "Il n'y a pas de répertoire ~ au delà de ~."
  5733.                       fehler(file_error, GETTEXT("no directory ~ above ~"));
  5734.                     }
  5735.                   if (eq(Car(STACK_0),S(Kwild_inferiors))) # newlist fängt mit '...\' an ?
  5736.                     { # :PARENT von "...\" aus liefert Error
  5737.                       pushSTACK(STACK_2); # Wert für Slot PATHNAME von FILE-ERROR
  5738.                       pushSTACK(directory_namestring(STACK_(2+1))); # Directory von pathname
  5739.                       # '"..\\" nach "...\\" ist unzulässig: ~'
  5740.                       //: DEUTSCH "\"..\\\\\" nach \"...\\\\\" ist unzulässig: ~"
  5741.                       //: ENGLISH "\"..\\\\\" after \"...\\\\\" is invalid: ~"
  5742.                       //: FRANCAIS "\"..\\\\\" après \"...\\\\\" n'est pas permis : ~"
  5743.                       fehler(file_error,  GETTEXT("\"..\\\\\" after \"...\\\\\" is invalid: ~"));
  5744.                     }
  5745.                   STACK_0 = Cdr(STACK_0);
  5746.                 }
  5747.               else # (auch wenn :ABSOLUTE !)
  5748.                 { # newlist um eins verlängern:
  5749.                   pushSTACK(subdir);
  5750.                  {var reg1 object new_cons = allocate_cons();
  5751.                   Car(new_cons) = popSTACK();
  5752.                   Cdr(new_cons) = STACK_0;
  5753.                   STACK_0 = new_cons;
  5754.                 }}
  5755.               STACK_1 = Cdr(STACK_1);
  5756.             }
  5757.           subdirs = nreverse(popSTACK()); # newlist, wieder umdrehen
  5758.           skipSTACK(1);
  5759.           # Stackaufbau: pathname.
  5760.           pathname = popSTACK();
  5761.           ThePathname(pathname)->pathname_directory = subdirs; # in den Pathname eintragen
  5762.         }
  5763.       return pathname;
  5764.     }
  5765.  
  5766. # UP: Stellt sicher, daß das Directory eines Pathname existiert.
  5767. # Sonst Fehlermeldung.
  5768. # assure_dir_exists_(tolerantp,dirtolerantp)
  5769. # > STACK_0: absoluter Pathname ohne Wildcards im Directory
  5770. # > tolerantp: Flag, ob ein Fehler vermieden werden soll
  5771. # > dirtolerantp: Don't complain if file ends up being a directory
  5772. # < ergebnis:
  5773. #     falls Name=NIL: Directory-Namestring (für DOS)
  5774. #     falls Name/=NIL: Namestring (für DOS, mit Nullbyte am Schluß)
  5775. #     falls tolerantp evtl.: nullobj
  5776. # kann GC auslösen
  5777.   local object assure_dir_exists_ (boolean tolerantp, boolean dirtolerantp);
  5778.   local object assure_dir_exists_(tolerantp,dirtolerantp)
  5779.     var reg4 boolean tolerantp;
  5780.     var reg5 boolean dirtolerantp;
  5781.     { var reg2 uintC stringcount = directory_namestring_parts(STACK_0); # Strings fürs Directory
  5782.       var reg1 object dir_namestring = string_concat(stringcount); # zusammenhängen
  5783.       # Existenztest:
  5784.       # 1. Subdir-List leer -> OK
  5785.       #    (Muß abgefangen werden, denn stat() auf Rootdir liefert Fehler.)
  5786.       # 2. OS/2: Subdir-List = ("PIPE") -> OK
  5787.       #    (Dieses Spezialverzeichnis "\\PIPE\\" ist in Wirklichkeit keines.)
  5788.       # 3. Sonst stat() probieren.
  5789.       if (!(nullp(Cdr(ThePathname(STACK_0)->pathname_directory))
  5790.             #ifdef PATHNAME_OS2
  5791.             || equal(Cdr(ThePathname(STACK_0)->pathname_directory),O(pipe_subdirs))
  5792.             #endif
  5793.          ) )
  5794.         {var struct stat statbuf;
  5795.          var reg3 uintB* endptr = &TheSstring(dir_namestring)->data[TheSstring(dir_namestring)->length-1];
  5796.          *endptr = '\0'; # '\' am Schluß durch Nullbyte ersetzen
  5797.          begin_system_call();
  5798.          if (stat(TheAsciz(dir_namestring),&statbuf) < 0)
  5799.            { end_system_call();
  5800.              if (tolerantp && (errno==ENOENT)) { return nullobj; }
  5801.              OS_error();
  5802.            }
  5803.          end_system_call();
  5804.          *endptr = '\\'; # wieder mit '\' abschließen
  5805.          if (!S_ISDIR(statbuf.st_mode)) # gefundene Datei kein Unterdirectory ?
  5806.            { if (tolerantp) { return nullobj; }
  5807.              fehler_dir_not_exists(dir_namestring);
  5808.         }  }
  5809.       if (namenullp(STACK_0))
  5810.         { return dir_namestring; }
  5811.         else
  5812.         { return namestring_asciz(dir_namestring); }
  5813.     }
  5814.  
  5815. # UP: Stellt sicher, daß das Directory eines Pathname existiert.
  5816. # Sonst Fehlermeldung.
  5817. # assure_dir_exists(tolerantp)
  5818. # > STACK_0: absoluter Pathname ohne Wildcards im Directory
  5819. # > tolerantp: Flag, ob ein Fehler vermieden werden soll
  5820. # < ergebnis:
  5821. #     falls Name=NIL: Directory-Namestring (für RISCOS, mit '.' am Schluß)
  5822. #     falls Name/=NIL: Namestring (für RISCOS, mit Nullbyte am Schluß)
  5823. #     falls tolerantp evtl.: nullobj
  5824. # < filestatus: Falls Name/=NIL: NULL falls das File nicht existiert,
  5825. #                                sonst ein Pointer auf eine STAT-Information.
  5826. # kann GC auslösen
  5827.   local object assure_dir_exists (boolean tolerantp);
  5828.   local object assure_dir_exists(tolerantp)
  5829.     var reg5 boolean tolerantp;
  5830.     { return assure_dir_exists_(tolerantp,FALSE);
  5831.     }
  5832.  
  5833. # UP: Liefert den Directory-Namestring eines Pathname unter der Annahme,
  5834. #     daß das Directory dieses Pathname existiert.
  5835. # assume_dir_exists()
  5836. # > STACK_0: absoluter Pathname ohne Wildcards im Directory
  5837. # < ergebnis:
  5838. #     falls Name=NIL: Directory-Namestring (für DOS bzw. GEMDOS, ohne Seriennummer)
  5839. #     falls Name/=NIL: Namestring (für DOS bzw. GEMDOS, ohne Seriennummer, mit Nullbyte am Schluß)
  5840. # kann GC auslösen
  5841.   global object assume_dir_exists (void);
  5842.   global object assume_dir_exists()
  5843.     { var reg2 uintC stringcount =
  5844.         directory_namestring_parts(STACK_0); # Strings fürs Directory
  5845.       var reg1 object dir_namestring = string_concat(stringcount); # zusammenhängen
  5846.       if (namenullp(STACK_0))
  5847.         { return dir_namestring; }
  5848.         else
  5849.         { return namestring_asciz(dir_namestring); }
  5850.     }
  5851.  
  5852. #endif
  5853.  
  5854. #ifdef PATHNAME_AMIGAOS
  5855.  
  5856. # UP: Liefert den Truename eines Directory-Locks.
  5857. # > set_break_sem_4(): schon ausgeführt
  5858. # > lock: Directory-Lock, wird freigegeben
  5859. # < ergebnis: Directory (als Pathname)
  5860. # kann GC auslösen
  5861.   local object directory_truename (BPTR lock);
  5862.   local object directory_truename(lock)
  5863.     var reg6 BPTR lock;
  5864.     { # Von hier aus hochhangeln:
  5865.       pushSTACK(NIL); # Subdir-Liste := NIL
  5866.       { var LONGALIGNTYPE(struct FileInfoBlock) fib;
  5867.         var reg5 struct FileInfoBlock * fibptr = LONGALIGN(&fib);
  5868.         loop
  5869.           { # Directory selbst ansehen:
  5870.             begin_system_call();
  5871.            {var reg1 LONG ergebnis = Examine(lock,fibptr);
  5872.             end_system_call();
  5873.             if (!ergebnis) { OS_error(); }
  5874.            }
  5875.             # seinen Namen verwenden:
  5876.            {var reg4 object name = asciz_to_string(&fibptr->fib_FileName[0]);
  5877.             # zum Parent-Directory hochsteigen:
  5878.             var reg3 BPTR parentlock;
  5879.             begin_system_call();
  5880.             parentlock = ParentDir(lock);
  5881.             UnLock(lock);
  5882.             end_system_call();
  5883.             if (!(parentlock==BPTR_NULL))
  5884.               # name ist der Name eines Subdirectories
  5885.               { # vor die Subdir-Liste pushen:
  5886.                 pushSTACK(name);
  5887.                {var reg1 object new_cons = allocate_cons();
  5888.                 Car(new_cons) = popSTACK();
  5889.                 Cdr(new_cons) = STACK_0;
  5890.                 STACK_0 = new_cons;
  5891.                }
  5892.                 lock = parentlock; # und vom Parent Directory aus weitermachen
  5893.               }
  5894.               else
  5895.               { begin_system_call();
  5896.                 if (IoErr()) { OS_error(); } # Fehler aufgetreten?
  5897.                 end_system_call();
  5898.                 # name ist der Name eines DOS-Volumes.
  5899.                 pushSTACK(name);
  5900.                 break;
  5901.               }
  5902.       }   }}
  5903.       clr_break_sem_4(); # Unterbrechungen wieder zulassen
  5904.       # Stackaufbau: subdirs, devicename.
  5905.      {# subdirs mit :ABSOLUTE anfangen lassen:
  5906.       var reg1 object new_cons = allocate_cons();
  5907.       Car(new_cons) = S(Kabsolute); Cdr(new_cons) = STACK_1;
  5908.       STACK_1 = new_cons;
  5909.      }
  5910.      {var reg1 object default_dir = allocate_pathname(); # neuer Pathname mit Name=NIL und Typ=NIL
  5911.       ThePathname(default_dir)->pathname_device = popSTACK();
  5912.       ThePathname(default_dir)->pathname_directory = popSTACK();
  5913.       return default_dir;
  5914.     }}
  5915.  
  5916. # UP: Liefert das aktuelle Directory.
  5917. # < ergebnis: aktuelles Directory (als Pathname)
  5918. # kann GC auslösen
  5919.   local object default_directory (void);
  5920.   local object default_directory()
  5921.     { # Lock fürs aktuelle Directory holen:
  5922.       set_break_sem_4(); # Unterbrechungen währenddessen verhindern
  5923.       begin_system_call();
  5924.      {var reg1 BPTR lock = Lock("",ACCESS_READ);
  5925.       if (lock==BPTR_NULL)
  5926.         { if (!(IoErr()==ERROR_OBJECT_NOT_FOUND)) { OS_error(); }
  5927.           pushSTACK(unbound); # "Wert" für Slot PATHNAME von FILE-ERROR
  5928.           //: DEUTSCH "Zugriff auf aktuelles Verzeichnis nicht möglich."
  5929.           //: ENGLISH "Couldn't access current directory"
  5930.           //: FRANCAIS "Le répertoire courant n'est pas accessible."
  5931.           fehler(file_error, GETTEXT("Couldn't access current directory"));
  5932.         }
  5933.       end_system_call();
  5934.       return directory_truename(lock); # macht clr_break_sem_4(); und UnLock(lock);
  5935.     }}
  5936.  
  5937. # UP: Füllt Default-Directory in einen Pathname ein.
  5938. # use_default_dir(pathname)
  5939. # > pathname: nicht-Logical Pathname
  5940. # < ergebnis: neuer absoluter Pathname
  5941. # kann GC auslösen
  5942.   local object use_default_dir (object pathname);
  5943.   local object use_default_dir(pathname)
  5944.     var reg3 object pathname;
  5945.     { # erst den Pathname kopieren:
  5946.       pathname = copy_pathname(pathname);
  5947.       # Dann das Default-Directory in den Pathname einbauen:
  5948.       { var reg2 object subdirs = ThePathname(pathname)->pathname_directory;
  5949.         # Fängt pathname-directory mit :RELATIVE an?
  5950.         if (eq(Car(subdirs),S(Krelative)))
  5951.           { # ja -> Ersetze :RELATIVE durch default-subdirs, d.h.
  5952.             # bilde  (append default-subdirs (cdr subdirs))
  5953.             #      = (nreconc (reverse default-subdirs) (cdr subdirs))
  5954.             pushSTACK(pathname);
  5955.             pushSTACK(Cdr(subdirs));
  5956.            {var reg1 object temp = default_directory();
  5957.             temp = ThePathname(temp)->pathname_directory;
  5958.             temp = reverse(temp);
  5959.             subdirs = nreconc(temp,popSTACK());
  5960.             pathname = popSTACK();
  5961.             # in den Pathname eintragen:
  5962.             ThePathname(pathname)->pathname_directory = subdirs;
  5963.           }}
  5964.       }
  5965.       return pathname;
  5966.     }
  5967.  
  5968. # UP: Macht aus einem Directory-Namestring einen, der für AMIGAOS geeignet ist.
  5969. # OSnamestring(namestring)
  5970. # > namestring: neu erzeugter Directory-Namestring, mit '/' oder ':' am
  5971. #               Schluß, ein Simple-String
  5972. # < ergebnis: Namestring zu diesem Directory, im AmigaOS-Format: letzter '/'
  5973. #             gestrichen, falls überflüssig, ASCIZ-String
  5974. # kann GC auslösen
  5975.   local object OSnamestring (object namestring);
  5976.   local object OSnamestring(namestring)
  5977.     var reg1 object namestring;
  5978.     { var reg2 uintL len = TheSstring(namestring)->length;
  5979.       if (len==0) goto ok; # Leerstring -> nichts streichen
  5980.      {var reg3 uintB ch = TheSstring(namestring)->data[len-1];
  5981.       if (!(ch=='/')) goto ok; # kein '/' am Schluß -> nichts streichen
  5982.       if (len==1) goto ok; # "/" bedeutet Parent -> nicht streichen
  5983.       ch = TheSstring(namestring)->data[len-2];
  5984.       if ((ch=='/') || (ch==':')) # davor ein '/' oder ':'
  5985.         goto ok; # -> bedeutet Parent -> nicht streichen
  5986.       # '/' am Schluß streichen, dann string_to_asciz:
  5987.         namestring = copy_string(namestring); # Länge bleibt dabei gleich!
  5988.         TheSstring(namestring)->data[len-1] = '\0';
  5989.         return namestring;
  5990.       ok: # nichts streichen
  5991.         return string_to_asciz(namestring);
  5992.     }}
  5993.  
  5994. # UP: Stellt sicher, daß das Directory eines Pathname existiert.
  5995. # assure_dir_exists(tolerantp,dirtolerantp)
  5996. # > STACK_0: nicht-Logical Pathname, bei dem Directory kein :RELATIVE enthält.
  5997. # > tolerantp: Flag, ob ein Fehler vermieden werden soll
  5998. # > dirtolerantp: Don't complain if file ends up being a directory
  5999. # > subr_self: Aufrufer (ein SUBR)
  6000. # < STACK_0: (evtl. derselbe) Pathname, aber aufgelöst.
  6001. # < ergebnis:
  6002. #     falls Name=NIL: Directory-Namestring (für AMIGAOS, mit '/' am Schluß)
  6003. #     falls Name/=NIL: Namestring (für AMIGAOS, mit Nullbyte am Schluß)
  6004. #     falls tolerantp evtl.: nullobj
  6005. # < filestatus: Falls Name/=NIL: NULL falls das File nicht existiert,
  6006. #                                sonst ein Pointer auf eine STAT-Information.
  6007. # kann GC auslösen
  6008.   local var struct FileInfoBlock * filestatus;
  6009.   local object assure_dir_exists_ (boolean tolerantp,boolean dirtolerantp);
  6010.   local object assure_dir_exists_(tolerantp,dirtolerantp)
  6011.     var reg5 boolean tolerantp;
  6012.     var reg6 boolean dirtolerantp;
  6013.     { # Zur Auflösung von :PARENTs, die über Root hinaussteigen,
  6014.       # müssen wir das Betriebssystem bemühen. Daher:
  6015.       var reg3 object dir_namestring;
  6016.       {var reg1 uintC stringcount = directory_namestring_parts(STACK_0); # Strings fürs Directory
  6017.        dir_namestring = string_concat(stringcount);
  6018.       }
  6019.       pushSTACK(dir_namestring);
  6020.       dir_namestring = OSnamestring(dir_namestring); # ohne überflüssigen '/' am Schluß
  6021.       # Lock für dieses Directory holen:
  6022.       set_break_sem_4(); # Unterbrechungen währenddessen verhindern
  6023.       begin_system_call();
  6024.      {var reg4 BPTR lock = Lock(TheAsciz(dir_namestring),ACCESS_READ);
  6025.       if (lock==BPTR_NULL)
  6026.         { var reg2 LONG errcode = IoErr();
  6027.           end_system_call();
  6028.           switch (errcode)
  6029.             { case ERROR_OBJECT_NOT_FOUND:
  6030.                 clr_break_sem_4();
  6031.                 if (tolerantp) { skipSTACK(1); return nullobj; }
  6032.                 fehler_dir_not_exists(STACK_0);
  6033.               case ERROR_ACTION_NOT_KNOWN:
  6034.                 # Ein Device, bei dem man keine Locks für Subdirectories holen
  6035.                 # kann! Hierbei muß es sich wohl um ein spezielles Device handeln
  6036.                 # (PIPE, CON, AUX, etc.).
  6037.                 # Wir stoppen die Subdirectory-Überprüfungen. Nicht einmal mehr
  6038.                 # Examine() rufen wir auf. Wir gehen im Gegenteil davon aus, daß
  6039.                 # das File im gewöhnlichen Sinne (noch) nicht existiert.
  6040.                 clr_break_sem_4(); # Unterbrechungen zulassen, da wir nun doch kein Lock belegt haben
  6041.                 if (namenullp(STACK_(0+1))) # kein File angesprochen?
  6042.                   { return popSTACK(); } # ja -> fertig
  6043.                   else
  6044.                   { var reg1 uintC stringcount = 1; # directory_namestring schon auf dem STACK
  6045.                     stringcount += file_namestring_parts(STACK_(0+1)); # Strings für den Filename
  6046.                     pushSTACK(O(null_string)); stringcount++; # und Nullbyte
  6047.                    {var reg2 object namestring = string_concat(stringcount); # zusammenhängen
  6048.                     filestatus = (struct FileInfoBlock *)NULL; # File existiert nicht, sagen wir
  6049.                     return namestring;
  6050.                   }}
  6051.               default:
  6052.                 OS_error();
  6053.         }   }
  6054.       end_system_call();
  6055.       dir_namestring = popSTACK();
  6056.       # und überprüfen, ob's ein Directory ist:
  6057.       { var LONGALIGNTYPE(struct FileInfoBlock) fib;
  6058.         var reg2 struct FileInfoBlock * fibptr = LONGALIGN(&fib);
  6059.         begin_system_call();
  6060.        {var reg1 LONG ergebnis = Examine(lock,fibptr);
  6061.         if (!ergebnis) { UnLock(lock); OS_error(); }
  6062.         if (!(fibptr->fib_DirEntryType > 0)) # etwa kein Directory?
  6063.           { UnLock(lock);
  6064.             end_system_call();
  6065.             if (tolerantp) { return nullobj; }
  6066.             # STACK_0 = Wert für Slot PATHNAME von FILE-ERROR
  6067.             pushSTACK(dir_namestring);
  6068.             pushSTACK(TheSubr(subr_self)->name);
  6069.             //: DEUTSCH "~: ~ ist ein File und kein Directory."
  6070.             //: ENGLISH "~: ~ names a file, not a directory"
  6071.             //: FRANCAIS "~ : ~ est un fichier et non un répertoire."
  6072.             fehler(file_error, GETTEXT("~: ~ names a file, not a directory"));
  6073.           }
  6074.         end_system_call();
  6075.       }}
  6076.       # Lock zum Truename machen:
  6077.       {var reg1 object new_pathname = directory_truename(lock); # macht clr_break_sem_4();
  6078.        var reg2 object old_pathname = STACK_0;
  6079.        ThePathname(new_pathname)->pathname_name = ThePathname(old_pathname)->pathname_name;
  6080.        ThePathname(new_pathname)->pathname_type = ThePathname(old_pathname)->pathname_type;
  6081.        STACK_0 = new_pathname;
  6082.      }}
  6083.      {var reg4 object pathname = STACK_0;
  6084.       # Information zum angesprochenen File holen:
  6085.       if (namenullp(pathname)) # kein File angesprochen?
  6086.         { return directory_namestring(pathname); } # ja -> fertig
  6087.       { var reg2 uintC stringcount = 0;
  6088.         stringcount += directory_namestring_parts(pathname); # Strings fürs Directory
  6089.         stringcount += file_namestring_parts(pathname); # Strings für den Filename
  6090.         pushSTACK(O(null_string)); stringcount++; # und Nullbyte
  6091.        {var reg1 object namestring = string_concat(stringcount); # zusammenhängen
  6092.         # Lock für dieses File holen:
  6093.           begin_system_call();
  6094.         { var reg3 BPTR lock = Lock(TheAsciz(namestring),ACCESS_READ);
  6095.           if (lock==BPTR_NULL)
  6096.             { if (!(IoErr()==ERROR_OBJECT_NOT_FOUND)) { OS_error(); }
  6097.               end_system_call();
  6098.               # File existiert nicht.
  6099.               filestatus = (struct FileInfoBlock *)NULL; return namestring;
  6100.             }
  6101.           end_system_call();
  6102.           # File existiert.
  6103.           # Information holen:
  6104.          {local var LONGALIGNTYPE(struct FileInfoBlock) status;
  6105.           var reg1 struct FileInfoBlock * statusptr = LONGALIGN(&status);
  6106.           begin_system_call();
  6107.           if (! Examine(lock,statusptr) ) { UnLock(lock); OS_error(); }
  6108.           UnLock(lock);
  6109.           end_system_call();
  6110.           if (statusptr->fib_DirEntryType > 0 && !dirtolerantp) # Ist es ein Directory?
  6111.             { # STACK_0 = Wert für Slot PATHNAME von FILE-ERROR
  6112.               pushSTACK(whole_namestring(STACK_0));
  6113.               pushSTACK(TheSubr(subr_self)->name);
  6114.               //: DEUTSCH "~: ~ ist ein Directory und kein File."
  6115.               //: ENGLISH "~: ~ names a directory, not a file"
  6116.               //: FRANCAIS "~ : ~ désigne un répertoire et non un fichier."
  6117.               fehler(file_error, GETTEXT("~: ~ names a directory, not a file"));
  6118.             }
  6119.             else
  6120.             # normales File
  6121.             { pushSTACK(namestring);
  6122.               # Die Groß-/Kleinschreibung des Truename wird bestimmt durch
  6123.               # das bereits existierende File.
  6124.               pushSTACK(asciz_to_string(&statusptr->fib_FileName[0]));
  6125.               split_name_type(1);
  6126.              {var reg1 object pathname = STACK_(0+3); # der kopierte Pathname
  6127.               ThePathname(pathname)->pathname_type = popSTACK();
  6128.               ThePathname(pathname)->pathname_name = popSTACK();
  6129.               # Fertig.
  6130.               filestatus = statusptr;
  6131.               return popSTACK(); # namestring
  6132.             }}
  6133.      }}}}}
  6134.     }
  6135.  
  6136. # UP: Stellt sicher, daß das Directory eines Pathname existiert.
  6137. # Sonst Fehlermeldung.
  6138. # assure_dir_exists(tolerantp)
  6139. # > STACK_0: absoluter Pathname ohne Wildcards im Directory
  6140. # > tolerantp: Flag, ob ein Fehler vermieden werden soll
  6141. # < ergebnis:
  6142. #     falls Name=NIL: Directory-Namestring (für RISCOS, mit '.' am Schluß)
  6143. #     falls Name/=NIL: Namestring (für RISCOS, mit Nullbyte am Schluß)
  6144. #     falls tolerantp evtl.: nullobj
  6145. # < filestatus: Falls Name/=NIL: NULL falls das File nicht existiert,
  6146. #                                sonst ein Pointer auf eine STAT-Information.
  6147. # kann GC auslösen
  6148.   local object assure_dir_exists (boolean tolerantp);
  6149.   local object assure_dir_exists(tolerantp)
  6150.     var reg5 boolean tolerantp;
  6151.     { return assure_dir_exists_(tolerantp,FALSE);
  6152.     }
  6153.  
  6154. # Dasselbe unter der Annahme, daß das Directory bereits existiert.
  6155. # (Keine Vereinfachung, da wir ja den Truename bestimmen müssen.)
  6156.   global object assume_dir_exists (void);
  6157.   global object assume_dir_exists()
  6158.     { subr_self = L(open); return assure_dir_exists(FALSE); }
  6159.  
  6160. #endif
  6161.  
  6162. #ifdef PATHNAME_UNIX
  6163.  
  6164. # UP: Liefert das aktuelle Directory.
  6165. # < ergebnis: aktuelles Directory (als Pathname)
  6166. # kann GC auslösen
  6167.   local object default_directory (void);
  6168.   local object default_directory()
  6169.     # Working Directory (von UNIX) ist das aktuelle Directory:
  6170.     { var char path_buffer[MAXPATHLEN]; # vgl. GETWD(3)
  6171.       # Working Directory in path_buffer ablegen:
  6172.       begin_system_call();
  6173.       if ( getwd(&path_buffer[0]) ==NULL)
  6174.         { pushSTACK(O(punkt_string)); # Wert für Slot PATHNAME von FILE-ERROR
  6175.           pushSTACK(asciz_to_string(&path_buffer[0])); # Meldung
  6176.           //: DEUTSCH "UNIX-Fehler bei GETWD: ~"
  6177.           //: ENGLISH "UNIX error while GETWD: ~"
  6178.           //: FRANCAIS "Erreur UNIX pendant GETWD : ~"
  6179.           fehler(file_error, GETTEXT("UNIX error while GETWD: ~"));
  6180.         }
  6181.       end_system_call();
  6182.       # Es muß mit '/' anfangen:
  6183.       if (!(path_buffer[0] == '/'))
  6184.         { pushSTACK(O(punkt_string)); # Wert für Slot PATHNAME von FILE-ERROR
  6185.           pushSTACK(asciz_to_string(&path_buffer[0]));
  6186.           //: DEUTSCH "UNIX GETWD lieferte ~"
  6187.           //: ENGLISH "UNIX GETWD returned ~"
  6188.           //: FRANCAIS "GETWD d'UNIX a retourné ~"
  6189.           fehler(file_error, GETTEXT("UNIX GETWD returned ~"));
  6190.         }
  6191.       # in Pathname umwandeln:
  6192.       return asciz_dir_to_pathname(&path_buffer[0]);
  6193.     }
  6194.  
  6195. # UP: Füllt Default-Directory in einen Pathname ein.
  6196. # use_default_dir(pathname)
  6197. # > pathname: nicht-Logical Pathname
  6198. # < ergebnis: neuer Pathname, bei dem Directory kein :RELATIVE enthält.
  6199. #             (kurz: "absoluter Pathname")
  6200. # kann GC auslösen
  6201.   local object use_default_dir (object pathname);
  6202.   local object use_default_dir(pathname)
  6203.     var reg3 object pathname;
  6204.     { # erst den Pathname kopieren:
  6205.       pathname = copy_pathname(pathname);
  6206.       # Dann das Default-Directory in den Pathname einbauen:
  6207.       { var reg2 object subdirs = ThePathname(pathname)->pathname_directory;
  6208.         # Fängt pathname-directory mit :RELATIVE an?
  6209.         if (eq(Car(subdirs),S(Krelative)))
  6210.           { # ja -> Ersetze :RELATIVE durch default-subdirs, d.h.
  6211.             # bilde  (append default-subdirs (cdr subdirs))
  6212.             #      = (nreconc (reverse default-subdirs) (cdr subdirs))
  6213.             pushSTACK(pathname);
  6214.             pushSTACK(Cdr(subdirs));
  6215.            {var reg1 object temp = default_directory();
  6216.             temp = ThePathname(temp)->pathname_directory;
  6217.             temp = reverse(temp);
  6218.             subdirs = nreconc(temp,popSTACK());
  6219.             pathname = popSTACK();
  6220.             # in den Pathname eintragen:
  6221.             ThePathname(pathname)->pathname_directory = subdirs;
  6222.           }}
  6223.       }
  6224.       return pathname;
  6225.     }
  6226.  
  6227. # UP: Stellt sicher, daß das Directory eines Pathname existiert, und löst
  6228. # dabei symbolische Links auf.
  6229. # assure_dir_exists_(tolerantp,dirtolerantp)
  6230. # > STACK_0: nicht-Logical Pathname, bei dem Directory kein :RELATIVE enthält.
  6231. # > tolerantp: Flag, ob ein Fehler vermieden werden soll
  6232. # > dirtolerantp:  Don't complain if file ends being a directory
  6233. # > subr_self: Aufrufer (ein SUBR)
  6234. # < STACK_0: (evtl. derselbe) Pathname, wobei weder fürs Directory noch
  6235. #            für den Filenamen ein symbolisches Link zu verfolgen ist.
  6236. # < ergebnis:
  6237. #     falls Name=NIL: Directory-Namestring (für UNIX, mit '/' am Schluß)
  6238. #     falls Name/=NIL: Namestring (für UNIX, mit Nullbyte am Schluß)
  6239. #     falls tolerantp evtl.: nullobj
  6240. # < filestatus: Falls Name/=NIL: NULL falls das File nicht existiert,
  6241. #                                sonst ein Pointer auf eine STAT-Information.
  6242. # kann GC auslösen
  6243.   local var struct stat * filestatus;
  6244.   local object assure_dir_exists_ (boolean tolerantp, boolean dirtolerantp);
  6245.   local object assure_dir_exists_(tolerantp,dirtolerantp)
  6246.     var reg7 boolean tolerantp;
  6247.     var reg8 boolean dirtolerantp;
  6248.     { var reg6 uintC allowed_links = MAXSYMLINKS; # Anzahl der noch erlaubten symbolischen Links
  6249.       loop # Schleife über die aufzulösenden symbolischen Links
  6250.         { # Truepath des Directory bestimmen:
  6251.           var char path_buffer[MAXPATHLEN]; # vgl. REALPATH(3)
  6252.           { var reg2 uintC stringcount = directory_namestring_parts(STACK_0); # Strings zum Directory
  6253.             pushSTACK(O(punkt_string)); # und "."
  6254.             pushSTACK(O(null_string)); # und Nullbyte
  6255.            {var reg1 object string = string_concat(stringcount+1+1); # zusammenhängen
  6256.             # symbolische Links darin auflösen:
  6257.             begin_system_call();
  6258.             if ( realpath(TheAsciz(string),&path_buffer[0]) ==NULL)
  6259.               { end_system_call();
  6260.                 if (!(errno==ENOENT)) { OS_error(); }
  6261.                 if (tolerantp) { return nullobj; }
  6262.                 fehler_dir_not_exists(asciz_dir_to_pathname(&path_buffer[0])); # fehlerhafte Komponente
  6263.               }
  6264.             end_system_call();
  6265.           }}
  6266.           # Neuer Directory-Path muß mit '/' anfangen:
  6267.           if (!(path_buffer[0] == '/'))
  6268.             { # STACK_0 = Wert für Slot PATHNAME von FILE-ERROR
  6269.               pushSTACK(asciz_to_string(&path_buffer[0]));
  6270.               //: DEUTSCH "UNIX REALPATH lieferte ~"
  6271.               //: ENGLISH "UNIX REALPATH returned ~"
  6272.               //: FRANCAIS "REALPATH d'UNIX a retourné ~"
  6273.               fehler(file_error, GETTEXT("UNIX REALPATH returned ~"));
  6274.             }
  6275.           # Am Schluß evtl. ein '/' anfügen:
  6276.           {var reg1 char* pathptr = &path_buffer[0];
  6277.            var reg2 uintL len = 0; # Stringlänge
  6278.            until (*pathptr == 0) { pathptr++; len++; } # ASCIZ-Stringende suchen
  6279.            if (!((len>0) && (pathptr[-1]=='/')))
  6280.              { *pathptr = '/'; len++; } # ein '/' anfügen
  6281.           # und in einen String umwandeln:
  6282.            { var reg4 object new_string = make_string((uintB*)(&path_buffer[0]),len);
  6283.           # Pathname draus machen und dessen Directory verwenden:
  6284.             {var reg3 object new_pathname = coerce_pathname(new_string);
  6285.              ThePathname(STACK_0)->pathname_directory
  6286.                = ThePathname(new_pathname)->pathname_directory;
  6287.           }}}
  6288.           # Information zum angesprochenen File holen:
  6289.           if (namenullp(STACK_0)) # kein File angesprochen?
  6290.             { return directory_namestring(STACK_0); } # ja -> fertig
  6291.           { var reg5 object pathname = STACK_0;
  6292.             var reg2 uintC stringcount = 0;
  6293.             stringcount += directory_namestring_parts(pathname); # Strings fürs Directory
  6294.             stringcount += file_namestring_parts(pathname); # Strings für den Filename
  6295.             pushSTACK(O(null_string)); stringcount++; # und Nullbyte
  6296.            {var reg1 object namestring = string_concat(stringcount); # zusammenhängen
  6297.             # Information holen:
  6298.             local struct stat status;
  6299.             begin_system_call();
  6300.             if (!( lstat(TheAsciz(namestring),&status) ==0))
  6301.               { if (!(errno==ENOENT)) { OS_error(); }
  6302.                 # File existiert nicht.
  6303.                 end_system_call();
  6304.                 filestatus = (struct stat *)NULL; return namestring;
  6305.               }
  6306.             end_system_call();
  6307.             # File existiert.
  6308.             if (S_ISDIR(status.st_mode) && !dirtolerantp) # Ist es ein Directory?
  6309.               { # STACK_0 = Wert für Slot PATHNAME von FILE-ERROR
  6310.                 pushSTACK(whole_namestring(STACK_0));
  6311.                 pushSTACK(TheSubr(subr_self)->name);
  6312.                 //: DEUTSCH "~: ~ ist ein Directory und kein File."
  6313.                 //: ENGLISH "~: ~ names a directory, not a file"
  6314.                 //: FRANCAIS "~ : ~ est un répertoire et non un fichier."
  6315.                 fehler(file_error, GETTEXT("~: ~ names a directory, not a file"));
  6316.               }
  6317.             #ifdef HAVE_LSTAT
  6318.             elif (S_ISLNK(status.st_mode)) # Ist es ein symbolisches Link?
  6319.               # ja -> weiterverfolgen:
  6320.               { if (allowed_links==0) # keine Links mehr erlaubt?
  6321.                   { errno = ELOOP_VALUE; OS_error(); } # ja -> UNIX-Error ELOOP simulieren
  6322.                 allowed_links--; # danach ist ein Link weniger erlaubt
  6323.                {var reg4 uintL linklen = status.st_size; # vermutliche Länge des Link-Inhalts
  6324.                 retry_readlink:
  6325.                   pushSTACK(namestring); # Namestring retten
  6326.                 { var reg3 object linkbuf = allocate_string(linklen); # Buffer für den Link-Inhalt
  6327.                   namestring = popSTACK();
  6328.                   # Link-Inhalt lesen:
  6329.                   begin_system_call();
  6330.                  {var reg1 int result = readlink(TheAsciz(namestring),TheAsciz(linkbuf),linklen);
  6331.                   end_system_call();
  6332.                   if (result<0) { OS_error(); }
  6333.                   if (!(result == (int)linklen)) # manchmal (AIX, NFS) stimmt status.st_size nicht
  6334.                     { linklen = result; goto retry_readlink; }
  6335.                   # Daraus ein Pathname machen:
  6336.                   # (MERGE-PATHNAMES (PARSE-NAMESTRING linkbuf) pathname)
  6337.                   pushSTACK(linkbuf); funcall(L(parse_namestring),1);
  6338.                   pushSTACK(value1); pushSTACK(STACK_(0+1)); funcall(L(merge_pathnames),2);
  6339.                   STACK_0 = value1;
  6340.               }}}}
  6341.             #endif
  6342.             else
  6343.               # normales File
  6344.               { filestatus = &status; return namestring; }
  6345.           }}
  6346.     }   }
  6347.  
  6348. # UP: Stellt sicher, daß das Directory eines Pathname existiert.
  6349. # Sonst Fehlermeldung.
  6350. # assure_dir_exists(tolerantp)
  6351. # > STACK_0: absoluter Pathname ohne Wildcards im Directory
  6352. # > tolerantp: Flag, ob ein Fehler vermieden werden soll
  6353. # < ergebnis:
  6354. #     falls Name=NIL: Directory-Namestring (für RISCOS, mit '.' am Schluß)
  6355. #     falls Name/=NIL: Namestring (für RISCOS, mit Nullbyte am Schluß)
  6356. #     falls tolerantp evtl.: nullobj
  6357. # < filestatus: Falls Name/=NIL: NULL falls das File nicht existiert,
  6358. #                                sonst ein Pointer auf eine STAT-Information.
  6359. # kann GC auslösen
  6360.   local object assure_dir_exists (boolean tolerantp);
  6361.   local object assure_dir_exists(tolerantp)
  6362.     var reg5 boolean tolerantp;
  6363.     { return assure_dir_exists_(tolerantp,FALSE);
  6364.     }
  6365.  
  6366. # Dasselbe unter der Annahme, daß das Directory bereits existiert.
  6367. # (Keine Vereinfachung, da das File ein symbolisches Link in ein anderes
  6368. # Directory sein kann, und dieses muß dann als existent überprüft werden.)
  6369.   global object assume_dir_exists (void);
  6370.   global object assume_dir_exists()
  6371.     { subr_self = L(open); return assure_dir_exists(FALSE); }
  6372.  
  6373. #endif
  6374.  
  6375. #ifdef PATHNAME_RISCOS
  6376.  
  6377. # Ein "absoluter Pathname" ist ein Pathname, bei dem Directory mit
  6378. # (:ABSOLUTE :ROOT ...) beginnt.
  6379.  
  6380. # UP: Liefert das aktuelle Directory.
  6381. # < ergebnis: aktuelles Directory (als Pathname)
  6382. # kann GC auslösen
  6383.   local object default_directory (void);
  6384.   local object default_directory()
  6385.     # Working Directory (von RISCOS) ist das aufgelöste "@":
  6386.     { var char path_buffer[MAXPATHLEN];
  6387.       # Working Directory in path_buffer ablegen:
  6388.       begin_system_call();
  6389.       if ( realpath("@",&path_buffer[0]) ==NULL) { OS_error(); }
  6390.       end_system_call();
  6391.       # in Pathname umwandeln:
  6392.       return asciz_dir_to_pathname(&path_buffer[0]);
  6393.     }
  6394.  
  6395. #if 0 # unbenutzt
  6396. # UP: Convert a valid RISCOS file namestring to an absolute pathname.
  6397. # canonicalise_filename(filename)
  6398. # > filename: Simple-Asciz-String
  6399. # < result: absolute pathname
  6400.   local object canonicalise_filename (object filename);
  6401.   local object canonicalise_filename(filename)
  6402.     var reg1 object filename;
  6403.     { var char path_buffer[MAXPATHLEN];
  6404.       begin_system_call();
  6405.       if ( realpath(TheAsciz(filename),&path_buffer[0]) ==NULL) { OS_error(); }
  6406.       end_system_call();
  6407.       # in Pathname umwandeln:
  6408.       return coerce_pathname(asciz_to_string(&path_buffer[0]));
  6409.     }
  6410. #endif
  6411.  
  6412. # UP: Convert a valid RISCOS directory namestring to an absolute pathname.
  6413. # canonicalise_dirname(pathname,dirname)
  6414. # > pathname: Pathname whose host name and device is to be used
  6415. # > dirname: Simple-String, ends with '.'
  6416. # < result: absolute pathname
  6417.   local object canonicalise_dirname (object pathname, object dirname);
  6418.   local object canonicalise_dirname(pathname,dirname)
  6419.     var reg5 object pathname;
  6420.     var reg4 object dirname;
  6421.     { var reg3 uintC stringcount = host_namestring_parts(pathname); # Strings für den Host
  6422.       # Device, vgl. directory_namestring_parts():
  6423.       { var reg1 object device = ThePathname(pathname)->pathname_device;
  6424.         if (!(nullp(device))) # NIL -> kein String
  6425.           { pushSTACK(O(doppelpunkt_string)); # ":"
  6426.             pushSTACK(device); # Device auf den Stack
  6427.             pushSTACK(O(punkt_string)); # "."
  6428.             stringcount += 3; # und mitzählen
  6429.       }   }
  6430.       pushSTACK(dirname);
  6431.      {var reg1 object dir_string = string_concat(stringcount+1);
  6432.       # Punkt am Schluß durch Nullbyte ersetzen:
  6433.       TheSstring(dir_string)->data[TheSstring(dir_string)->length-1] = '\0';
  6434.       # absolut machen:
  6435.       { var char path_buffer[MAXPATHLEN];
  6436.         begin_system_call();
  6437.         if ( realpath(TheAsciz(dir_string),&path_buffer[0]) ==NULL) { OS_error(); }
  6438.         end_system_call();
  6439.         # in Pathname umwandeln:
  6440.         return asciz_dir_to_pathname(&path_buffer[0]);
  6441.     }}}
  6442.  
  6443. # UP: Füllt Default-Directory in einen Pathname ein.
  6444. # use_default_dir(pathname)
  6445. # > pathname: nicht-Logical Pathname
  6446. # < ergebnis: neuer Pathname, bei dem Directory kein :RELATIVE u.ä. enthält.
  6447. #             (kurz: "absoluter Pathname")
  6448. # kann GC auslösen
  6449.   local object use_default_dir (object pathname);
  6450.   local object use_default_dir(pathname)
  6451.     var reg3 object pathname;
  6452.     { var reg5 boolean resolved_root = FALSE;
  6453.       retry:
  6454.       # erst den Pathname kopieren:
  6455.       pathname = copy_pathname(pathname);
  6456.      {var reg2 object subdirs = ThePathname(pathname)->pathname_directory;
  6457.       # Ist das Device angegeben, so muß das Directory mit (:ABSOLUTE :ROOT ...)
  6458.       # anfangen (oder mit (:RELATIVE ...) - das wird ersetzt).
  6459.       if (!nullp(ThePathname(pathname)->pathname_device))
  6460.         { if (eq(Car(subdirs),S(Krelative)))
  6461.             { pushSTACK(pathname); # pathname retten
  6462.               pushSTACK(allocate_cons());
  6463.              {var reg1 object new_cons = allocate_cons();
  6464.               subdirs = popSTACK();
  6465.               pathname = popSTACK(); # pathname zurück
  6466.               Car(subdirs) = S(Kabsolute); Cdr(subdirs) = new_cons;
  6467.               Car(new_cons) = S(Kroot); Cdr(new_cons) = Cdr(ThePathname(pathname)->pathname_directory);
  6468.               ThePathname(pathname)->pathname_directory = subdirs;
  6469.             }}
  6470.           elif (!(eq(Car(subdirs),S(Kabsolute)) && eq(Car(Cdr(subdirs)),S(Kroot))))
  6471.             { pushSTACK(pathname); # Wert für Slot PATHNAME von FILE-ERROR
  6472.               pushSTACK(pathname);
  6473.               pushSTACK(O(root_string));
  6474.               pushSTACK(TheSubr(subr_self)->name);
  6475.               //: DEUTSCH "~: Ist ein Device angegeben, muß das Directory mit ~ anfangen: ~"
  6476.               //: ENGLISH "~: If a device is specified, the directory must begin with ~: ~"
  6477.               //: FRANCAIS "~ : Quand un composant DEVICE est spécifié, le répertoire doit commencer par ~: ~"
  6478.               fehler(file_error, GETTEXT("~: If a device is specified, the directory must begin with ~: ~"));
  6479.             }
  6480.         }
  6481.       pushSTACK(pathname); # pathname retten
  6482.       {var reg4 object defaults;
  6483.        if (eq(Car(subdirs),S(Krelative)))
  6484.          { pushSTACK(Cdr(subdirs)); defaults = default_directory(); }
  6485.        else # (eq(Car(subdirs),S(Kabsolute)))
  6486.          { var reg1 object next = Car(Cdr(subdirs));
  6487.            pushSTACK(Cdr(Cdr(subdirs)));
  6488.            if (eq(next,S(Kroot))) # :ROOT -> "$." auflösen oder fertig
  6489.              { # "$." wird nur dann aufgelöst, wenn Host oder Device noch
  6490.                # unbekannt sind, aber nur einmal (um eine Endlosschleife zu
  6491.                # verhindern). Ob Host oder Device =NIL sind, ist nämlich
  6492.                # nicht so wichtig.
  6493.                if (!resolved_root
  6494.                    && (nullp(ThePathname(pathname)->pathname_host)
  6495.                        || nullp(ThePathname(pathname)->pathname_device)
  6496.                   )   )
  6497.                  { defaults = canonicalise_dirname(pathname,O(root_string));
  6498.                    resolved_root = TRUE;
  6499.                  }
  6500.                else
  6501.                  { goto resolved; }
  6502.              }
  6503.            elif (eq(next,S(Khome))) # :HOME -> "&." auflösen
  6504.              { defaults = canonicalise_dirname(pathname,O(home_string)); }
  6505.            elif (eq(next,S(Kcurrent))) # :CURRENT -> "@." auflösen
  6506.              { defaults = canonicalise_dirname(pathname,O(current_string)); }
  6507.            elif (eq(next,S(Klibrary))) # :LIBRARY -> "%." auflösen
  6508.              { defaults = canonicalise_dirname(pathname,O(library_string)); }
  6509.            elif (eq(next,S(Kprevious))) # :PREVIOUS -> "\\." auflösen
  6510.              { defaults = canonicalise_dirname(pathname,O(previous_string)); }
  6511.            else
  6512.              { NOTREACHED }
  6513.          }
  6514.        # Stackaufbau: pathname, rest-subdirs.
  6515.        # Nicht ganz so wie bei MERGE-PATHNAMES verfahren:
  6516.        # bilde  (append default-subdirs rest-subdirs)
  6517.        #      = (nreconc (reverse default-subdirs) rest-subdirs)
  6518.        pathname = STACK_1;
  6519.        ThePathname(pathname)->pathname_host = ThePathname(defaults)->pathname_host;
  6520.        ThePathname(pathname)->pathname_device = ThePathname(defaults)->pathname_device;
  6521.        defaults = ThePathname(defaults)->pathname_directory;
  6522.        defaults = reverse(defaults); subdirs = nreconc(defaults,popSTACK());
  6523.        pathname = popSTACK();
  6524.        ThePathname(pathname)->pathname_directory = subdirs;
  6525.        # Es könnte sein, daß auch jetzt noch nicht alles aufgelöst ist.
  6526.        goto retry;
  6527.      }}
  6528.      resolved: # Stackaufbau: pathname, subdir-oldlist.
  6529.       # Liste durchgehen und dabei neu aufconsen, dabei "^." verarbeiten.
  6530.       # (Sonst müßte dies assure_dir_exists() machen.)
  6531.       pushSTACK(S(Kroot)); pushSTACK(S(Kabsolute));
  6532.       { var reg1 object newlist = listof(2); pushSTACK(newlist); }
  6533.       # Stackaufbau: pathname, subdir-oldlist, subdir-newlist.
  6534.       while (mconsp(STACK_1)) # Bis oldlist am Ende ist:
  6535.         { var reg4 object subdir = Car(STACK_1); # nächstes subdir
  6536.           if (eq(subdir,S(Kparent)))
  6537.             # = :PARENT -> newlist um eins verkürzen:
  6538.             { if (matomp(Cdr(Cdr(STACK_0)))) # newlist (bis auf :ABSOLUTE und :ROOT) leer ?
  6539.                 { # :PARENT von "$." aus liefert Error
  6540.                   pushSTACK(STACK_2); # Wert für Slot PATHNAME von FILE-ERROR
  6541.                   pushSTACK(O(root_string)); # "$."
  6542.                   pushSTACK(directory_namestring(STACK_(2+2))); # Directory von pathname
  6543.                   //: DEUTSCH "Directory ~ oberhalb ~ existiert nicht."
  6544.                   //: ENGLISH "no directory ~ above ~"
  6545.                   //: FRANCAIS "Il n'y a pas de répertoire ~ au delà de ~."
  6546.                   fehler(file_error, GETTEXT("no directory ~ above ~"));
  6547.                 }
  6548.               STACK_0 = Cdr(STACK_0);
  6549.             }
  6550.           else
  6551.             { # newlist um eins verlängern:
  6552.               pushSTACK(subdir);
  6553.              {var reg1 object new_cons = allocate_cons();
  6554.               Car(new_cons) = popSTACK();
  6555.               Cdr(new_cons) = STACK_0;
  6556.               STACK_0 = new_cons;
  6557.             }}
  6558.           STACK_1 = Cdr(STACK_1);
  6559.         }
  6560.      {var reg2 object subdirs = nreverse(popSTACK()); # newlist, wieder umdrehen
  6561.       skipSTACK(1);
  6562.       pathname = popSTACK();
  6563.       ThePathname(pathname)->pathname_directory = subdirs; # in den Pathname eintragen
  6564.       return pathname;
  6565.     }}
  6566.  
  6567. # UP: Liefert den Namestring eines Pathname als ASCIZ-String.
  6568. # namestring_asciz(dir_namestring)
  6569. # > STACK_0: nicht-Logical Pathname
  6570. # > dir_namestring: Directory-Namestring
  6571. # < ergebnis: Namestring (für RISCOS, mit Name/Type vertauscht, mit Nullbyte am Schluß)
  6572. # kann GC auslösen
  6573.   local object namestring_asciz (object dir_namestring);
  6574.   local object namestring_asciz(dir_namestring)
  6575.     var reg3 object dir_namestring;
  6576.     { var reg1 object pathname = STACK_0;
  6577.       var reg2 uintC stringcount;
  6578.       pushSTACK(dir_namestring); # Directory-Namestring als 1. String
  6579.       stringcount = # und Strings zum Filenamen
  6580.         (nullp(ThePathname(pathname)->pathname_type)
  6581.          ? nametype_namestring_parts(ThePathname(pathname)->pathname_name,
  6582.                                      ThePathname(pathname)->pathname_type,
  6583.                                      ThePathname(pathname)->pathname_version)
  6584.          # Name und Typ vertauschen (der Typ wird zu einem Subdirectory-Namen):
  6585.          : nametype_namestring_parts(ThePathname(pathname)->pathname_type,
  6586.                                      ThePathname(pathname)->pathname_name,
  6587.                                      ThePathname(pathname)->pathname_version)
  6588.         );
  6589.       pushSTACK(O(null_string)); # und String mit Nullbyte
  6590.       return string_concat(1+stringcount+1); # zusammenhängen
  6591.     }
  6592.  
  6593. # UP: Stellt sicher, daß das Directory eines Pathname existiert.
  6594. # Sonst Fehlermeldung.
  6595. # assure_dir_exists_(tolerantp,dirtolerantp)
  6596. # > STACK_0: absoluter Pathname ohne Wildcards im Directory
  6597. # > tolerantp: Flag, ob ein Fehler vermieden werden soll
  6598. # > dirtolerantp: Don't complain if pathname is a directory
  6599. # < ergebnis:
  6600. #     falls Name=NIL: Directory-Namestring (für RISCOS, mit '.' am Schluß)
  6601. #     falls Name/=NIL: Namestring (für RISCOS, mit Nullbyte am Schluß)
  6602. #     falls tolerantp evtl.: nullobj
  6603. # < filestatus: Falls Name/=NIL: NULL falls das File nicht existiert,
  6604. #                                sonst ein Pointer auf eine STAT-Information.
  6605. # kann GC auslösen
  6606.   local var struct stat * filestatus;
  6607.   local object assure_dir_exists_ (boolean tolerantp, boolean dirtolerantp);
  6608.   local object assure_dir_exists_(tolerantp,dirtolerantp)
  6609.     var reg5 boolean tolerantp;
  6610.     var reg6 boolean dirtolerantp;
  6611.     { var reg4 object pathname = STACK_0;
  6612.       var reg2 uintC stringcount = host_namestring_parts(pathname); # Strings für den Host
  6613.       stringcount += directory_namestring_parts(pathname); # Strings fürs Directory
  6614.      {var reg1 object dir_namestring = string_concat(stringcount); # zusammenhängen
  6615.       # Existenztest:
  6616.       var struct stat statbuf;
  6617.       var reg1 uintL len = TheSstring(dir_namestring)->length;
  6618.       ASSERT((len > 0) && (TheSstring(dir_namestring)->data[len-1]=='.'));
  6619.       TheSstring(dir_namestring)->data[len-1] = '\0'; # '.' am Schluß durch Nullbyte ersetzen
  6620.       begin_system_call();
  6621.       if (stat(TheAsciz(dir_namestring),&statbuf) < 0)
  6622.         { end_system_call();
  6623.           if (tolerantp && (errno==ENOENT)) { return nullobj; }
  6624.           OS_error();
  6625.         }
  6626.       end_system_call();
  6627.       TheSstring(dir_namestring)->data[len-1] = '.'; # '.' wieder zurück
  6628.       if (!S_ISDIR(statbuf.st_mode)) # gefundene Datei kein Unterdirectory ?
  6629.         { if (tolerantp) { return nullobj; }
  6630.           fehler_dir_not_exists(dir_namestring);
  6631.         }
  6632.       # Information zum angesprochenen File holen:
  6633.       if (namenullp(STACK_0)) # kein File angesprochen?
  6634.         { return dir_namestring; } # ja -> fertig
  6635.         else
  6636.         { var reg3 object namestring = namestring_asciz(dir_namestring);
  6637.           # Information holen:
  6638.           local struct stat status;
  6639.           begin_system_call();
  6640.           if (stat(TheAsciz(namestring),&status) < 0)
  6641.             { if (!(errno==ENOENT)) { OS_error(); }
  6642.               # File existiert nicht.
  6643.               end_system_call();
  6644.               filestatus = (struct stat *)NULL; return namestring;
  6645.             }
  6646.           end_system_call();
  6647.           # File existiert.
  6648.           if (S_ISDIR(status.st_mode) && !dirtolerantp) # Ist es ein Directory?
  6649.             { # STACK_0 = Wert für Slot PATHNAME von FILE-ERROR
  6650.               pushSTACK(whole_namestring(STACK_0));
  6651.               pushSTACK(TheSubr(subr_self)->name);
  6652.               //: DEUTSCH "~: ~ ist ein Directory und kein File."
  6653.               //: ENGLISH "~: ~ names a directory, not a file"
  6654.               //: FRANCAIS "~ : ~ est un répertoire et non un fichier."
  6655.               fehler(file_error, GETTEXT("~: ~ names a directory, not a file"));
  6656.             }
  6657.           else
  6658.             # normales File
  6659.             { filestatus = &status; return namestring; }
  6660.     }}  }
  6661.  
  6662. # UP: Stellt sicher, daß das Directory eines Pathname existiert.
  6663. # Sonst Fehlermeldung.
  6664. # assure_dir_exists(tolerantp)
  6665. # > STACK_0: absoluter Pathname ohne Wildcards im Directory
  6666. # > tolerantp: Flag, ob ein Fehler vermieden werden soll
  6667. # < ergebnis:
  6668. #     falls Name=NIL: Directory-Namestring (für RISCOS, mit '.' am Schluß)
  6669. #     falls Name/=NIL: Namestring (für RISCOS, mit Nullbyte am Schluß)
  6670. #     falls tolerantp evtl.: nullobj
  6671. # < filestatus: Falls Name/=NIL: NULL falls das File nicht existiert,
  6672. #                                sonst ein Pointer auf eine STAT-Information.
  6673. # kann GC auslösen
  6674.   local object assure_dir_exists (boolean tolerantp)
  6675.   local object assure_dir_exists(tolerantp)
  6676.     var reg5 boolean tolerantp;
  6677.     { return assure_dir_exists_(tolerantp,FALSE);
  6678.     }
  6679.  
  6680. # Dasselbe unter der Annahme, daß das Directory bereits existiert.
  6681. # (Keine Vereinfachung, da wir ja den Truename bestimmen müssen.)
  6682.   global object assume_dir_exists (void);
  6683.   global object assume_dir_exists()
  6684.     { subr_self = L(open); return assure_dir_exists(FALSE); }
  6685.  
  6686. # Ein File "name.type" wird dem RISCOS als "type.name" vermittelt, dabei ist
  6687. # "type" der Name eines Unterverzeichnisses! Soll ein File "name.type" angelegt
  6688. # werden, muß daher zuerst das Unterverzeichnis "type" erzeugt werden.
  6689. # prepare_create(pathname);
  6690. # > pathname: ein Pathname
  6691. # kann GC auslösen
  6692.   local void prepare_create (object pathname);
  6693.   local object pathname_add_subdir (void);
  6694.   local void prepare_create(pathname)
  6695.     var reg1 object pathname;
  6696.     { if (!nullp(ThePathname(pathname)->pathname_type))
  6697.         { # call pathname_add_subdir:
  6698.           pushSTACK(pathname); pushSTACK(ThePathname(pathname)->pathname_type);
  6699.           pathname = pathname_add_subdir();
  6700.           ThePathname(pathname)->pathname_name = NIL;
  6701.           ThePathname(pathname)->pathname_type = NIL;
  6702.           # call MAKE-DIR if the directory does not exist:
  6703.           pushSTACK(subr_self); # subr_self retten
  6704.           pushSTACK(pathname);
  6705.           if (eq(assure_dir_exists(TRUE),nullobj))
  6706.             { funcall(L(make_dir),1); }
  6707.           else
  6708.             { skipSTACK(1); }
  6709.           subr_self = popSTACK(); # subr_self zurück
  6710.     }   }
  6711.  
  6712. #endif
  6713.  
  6714. #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  6715. #if 0 # unbenutzt
  6716. # UP: Macht aus einem Directory-Namestring einen, der für DOS geeignet ist.
  6717. # OSnamestring(namestring)
  6718. # > namestring: neu erzeugter Directory-Namestring, mit '\' am Schluß,
  6719. #               ein Simple-String
  6720. # < ergebnis: Namestring zu diesem Directory, im DOS-Format: letzter '\'
  6721. #             gestrichen, falls überflüssig, ASCIZ-String
  6722. # kann GC auslösen
  6723.   local object OSnamestring (object namestring);
  6724.   local object OSnamestring(namestring)
  6725.     var reg1 object namestring;
  6726.     { var reg2 uintL len = TheSstring(namestring)->length;
  6727.       if (len==0) goto ok; # Leerstring -> nichts streichen
  6728.      {var reg3 uintB ch = TheSstring(namestring)->data[len-1];
  6729.       if (!(ch=='\\')) goto ok; # kein '\' am Schluß -> nichts streichen
  6730.       if (len==1) goto ok; # "\" bedeutet Root -> nicht streichen
  6731.       ch = TheSstring(namestring)->data[len-2];
  6732.       if ((ch=='\\') || (ch==':')) # davor ein '\' oder ':'
  6733.         goto ok; # -> bedeutet Parent -> nicht streichen
  6734.       # '\' am Schluß streichen, dann string_to_asciz:
  6735.         namestring = copy_string(namestring); # Länge bleibt dabei gleich!
  6736.         TheSstring(namestring)->data[len-1] = '\0';
  6737.         return namestring;
  6738.       ok: # nichts streichen
  6739.         return string_to_asciz(namestring);
  6740.     }}
  6741. #endif
  6742. # UP: Setzt das Default-Drive und sein Default-Directory neu.
  6743. # change_default();
  6744. # > STACK_0: absoluter Pathname, bei dem Device ein String ist und Directory
  6745. #     kein :RELATIVE, :CURRENT, :PARENT enthält, und Name und Typ =NIL sind.
  6746. # kann GC auslösen
  6747.   local void change_default (void);
  6748.   local void change_default()
  6749.     { # Default-Directory zu diesem Drive neu setzen:
  6750.       { var reg1 object pathname = STACK_0;
  6751.         var reg3 uintC stringcount =
  6752.           directory_namestring_parts(pathname); # Strings fürs Directory
  6753.         # ohne überflüssiges '\' am Schluß, aber mit Nullbyte am Schluß
  6754.         if (mconsp(Cdr(ThePathname(pathname)->pathname_directory)))
  6755.           { STACK_0 = O(null_string); }
  6756.           else
  6757.           { pushSTACK(O(null_string)); stringcount++; }
  6758.        {var reg2 object string = string_concat(stringcount); # zusammenhängen
  6759.         # Default-Directory ändern:
  6760.         begin_system_call();
  6761.         if (!( chdir(TheAsciz(string)) ==0)) { OS_error(); }
  6762.         end_system_call();
  6763.       }}
  6764.       # Default-Drive neu setzen:
  6765.       O(default_drive) = ThePathname(STACK_0)->pathname_device;
  6766.       # *DEFAULT-PATHNAME-DEFAULTS* neu setzen:
  6767.       recalc_defaults_pathname();
  6768.     }
  6769. #endif
  6770. #ifdef PATHNAME_AMIGAOS
  6771. # UP: Setzt das Default-Directory neu.
  6772. # change_default();
  6773. # > STACK_0: absoluter Pathname, bei dem Directory kein :RELATIVE, :CURRENT,
  6774. #     :PARENT enthält, und Name und Typ =NIL sind.
  6775. # kann GC auslösen
  6776.   local void change_default (void);
  6777.   extern BPTR orig_dir_lock; # Lock auf das ursprüngliche Verzeichnis
  6778.                              # (das gehört nicht uns, nicht freigeben!)
  6779.   local void change_default()
  6780.     { var reg3 uintC stringcount =
  6781.         directory_namestring_parts(STACK_0); # Strings fürs Directory
  6782.       var reg2 object dir_namestring = string_concat(stringcount);
  6783.       dir_namestring = OSnamestring(dir_namestring); # Asciz, ohne überflüssigen '/' am Schluß
  6784.       # Default-Directory ändern:
  6785.       set_break_sem_4();
  6786.       begin_system_call();
  6787.       {var reg1 BPTR lock = Lock(TheAsciz(dir_namestring),ACCESS_READ);
  6788.        if (lock==BPTR_NULL) { OS_error(); }
  6789.        lock = CurrentDir(lock); # current directory neu setzen
  6790.        # Lock zum alten current directory merken bzw. aufgeben:
  6791.        if (orig_dir_lock == BPTR_NONE)
  6792.          { orig_dir_lock = lock; }
  6793.          else
  6794.          { UnLock(lock); }
  6795.       }
  6796.       end_system_call();
  6797.       clr_break_sem_4();
  6798.     }
  6799. #endif
  6800. #ifdef PATHNAME_UNIX
  6801. # UP: Setzt das Default-Directory neu.
  6802. # change_default();
  6803. # > STACK_0: absoluter Pathname, bei dem Directory kein :RELATIVE, :CURRENT,
  6804. #     :PARENT enthält, und Name und Typ =NIL sind.
  6805. # kann GC auslösen
  6806.   local void change_default (void);
  6807.   local void change_default()
  6808.     { var reg2 uintC stringcount = host_namestring_parts(STACK_0); # Strings für den Host
  6809.       stringcount += directory_namestring_parts(STACK_0); # Strings fürs Directory
  6810.       pushSTACK(O(null_string)); # und Nullbyte
  6811.      {var reg1 object string = string_concat(stringcount+1); # zusammenhängen
  6812.       # Default-Directory ändern:
  6813.       begin_system_call();
  6814.       if (!( chdir(TheAsciz(string)) ==0)) { OS_error(); }
  6815.       end_system_call();
  6816.     }}
  6817. #endif
  6818. #ifdef PATHNAME_RISCOS
  6819. # UP: Setzt das Default-Directory neu.
  6820. # change_default();
  6821. # > STACK_0: absoluter Pathname, bei dem Name und Typ =NIL sind.
  6822. # kann GC auslösen
  6823.   local void change_default (void);
  6824.   local void change_default()
  6825.     { var reg4 object pathname = STACK_0;
  6826.       var reg2 uintC stringcount = host_namestring_parts(pathname); # Strings für den Host
  6827.       stringcount += directory_namestring_parts(pathname); # Strings fürs Directory
  6828.      {var reg1 object dir_namestring = string_concat(stringcount); # zusammenhängen
  6829.       var reg3 uintL len = TheSstring(dir_namestring)->length;
  6830.       ASSERT((len > 0) && (TheSstring(dir_namestring)->data[len-1]=='.'));
  6831.       TheSstring(dir_namestring)->data[len-1] = '\0'; # '.' am Schluß durch Nullbyte ersetzen
  6832.       begin_system_call();
  6833.       if (!( chdir(TheAsciz(dir_namestring)) ==0)) { OS_error(); }
  6834.       end_system_call();
  6835.     }}
  6836. #endif
  6837.  
  6838. LISPFUN(namestring,1,1,norest,nokey,0,NIL)
  6839. # (NAMESTRING pathname), CLTL S. 417
  6840. # (NAMESTRING pathname t) -> Namestring im externen Format
  6841. #   GEMDOS: ohne Seriennummer, mit Default-Directory
  6842. #   Unix: mit Default-Directory
  6843.   { var reg2 object flag = popSTACK(); # optionales Argument flag
  6844.     var reg1 object pathname = coerce_pathname(popSTACK()); # Argument zu einem Pathname machen
  6845.     #if defined(PATHNAME_UNIX) || defined(PATHNAME_AMIGAOS) || defined(PATHNAME_RISCOS)
  6846.     if (!eq(flag,unbound) && !nullp(flag))
  6847.       # flag /= NIL -> fürs Betriebssystem:
  6848.       { check_no_wildcards(pathname); # mit Wildcards -> Fehler
  6849.         pathname = use_default_dir(pathname); # Default-Directory einfügen
  6850.         # (da GEMDOS/Unix/AMIGAOS das Default-Directory von LISP nicht kennt)
  6851.         value1 = whole_namestring(pathname);
  6852.       }
  6853.       else
  6854.     #endif
  6855.       # normal
  6856.       { value1 = whole_namestring(pathname); }
  6857.     mv_count=1;
  6858.   }
  6859.  
  6860. # Fehlermeldung wegen fehlendem Dateinamen
  6861. # fehler_noname(pathname);
  6862. # > pathname: Pathname
  6863.   nonreturning_function(local, fehler_noname, (object pathname));
  6864.   local void fehler_noname(pathname)
  6865.     var reg1 object pathname;
  6866.     { pushSTACK(pathname); # Wert für Slot PATHNAME von FILE-ERROR
  6867.       pushSTACK(pathname);
  6868.       //: DEUTSCH "Dateiname muß angegeben werden: ~"
  6869.       //: ENGLISH "no file name given: ~"
  6870.       //: FRANCAIS "Un nom de fichier doit être fourni : ~"
  6871.       fehler(file_error, GETTEXT("no file name given: ~"));
  6872.     }
  6873.  
  6874. # Test, ob ein File existiert:
  6875. # if_file_exists(namestring,statement1,statement2);
  6876. # > vorausgegangen: assure_dir_exists()
  6877. # > im STACK: Pathname, wie nach Ausführung von assure_dir_exists(), Name/=NIL
  6878. # > namestring: dessen Namestring als ASCIZ-String
  6879. # Falls das File existiert, wird statement1 ausgeführt, sonst statement2.
  6880.     #define if_file_exists(namestring,statement1,statement2)  \
  6881.       { if (file_exists(namestring)) { statement1; } else { statement2; } }
  6882.     #ifdef MSDOS
  6883.       local int access0 (CONST char* path);
  6884.       local int access0(path)
  6885.         var reg2 CONST char* path;
  6886.         { var reg1 int erg;
  6887.           begin_system_call();
  6888.           erg = access(path,0);
  6889.           end_system_call();
  6890.           return erg;
  6891.         }
  6892.       #define file_exists(namestring)  (access0(TheAsciz(namestring))==0)
  6893.     #endif
  6894.     #ifdef AMIGAOS
  6895.       #define file_exists(namestring)  (!(filestatus == (struct FileInfoBlock *)NULL))
  6896.     #endif
  6897.     #if defined(UNIX) || defined(RISCOS) || defined(WIN32_UNIX)
  6898.       #define file_exists(namestring)  (!(filestatus == (struct stat *)NULL))
  6899.     #endif
  6900.  
  6901. # Fehlermeldung wegen nicht existenter Datei
  6902. # fehler_file_not_exists();
  6903. # > STACK_0: Pathname
  6904. # > subr_self: Aufrufer (ein SUBR)
  6905.   nonreturning_function(local, fehler_file_not_exists, (void));
  6906.   local void fehler_file_not_exists()
  6907.     { # STACK_0 = Wert für Slot PATHNAME von FILE-ERROR
  6908.       pushSTACK(STACK_0); # pathname
  6909.       pushSTACK(TheSubr(subr_self)->name);
  6910.       //: DEUTSCH "~: Datei ~ existiert nicht."
  6911.       //: ENGLISH "~: file ~ does not exist"
  6912.       //: FRANCAIS "~ : Le fichier ~ n'existe pas."
  6913.       fehler(file_error, GETTEXT("~: file ~ does not exist"));
  6914.     }
  6915.  
  6916. LISPFUNN(truename,1)
  6917. # (TRUENAME pathname), CLTL S. 413
  6918.   { var reg1 object pathname = popSTACK(); # pathname-Argument
  6919.     if (streamp(pathname))
  6920.       # Stream -> extra behandeln:
  6921.       { # muß File-Stream sein:
  6922.         pathname = as_file_stream(pathname);
  6923.         # Streamtyp File-Stream
  6924.         value1 = TheStream(pathname)->strm_file_truename;
  6925.       }
  6926.       else
  6927.       { pathname = coerce_pathname(pathname); # zu einem Pathname machen
  6928.         check_no_wildcards(pathname); # mit Wildcards -> Fehler
  6929.         pathname = use_default_dir(pathname); # Default-Directory einfügen
  6930.         pushSTACK(pathname);
  6931.        {# Directory muß existieren:
  6932.         var reg3 object namestring = assure_dir_exists_(FALSE,TRUE); # Filename als ASCIZ-String
  6933.         if (namenullp(STACK_0))
  6934.           # Kein Name angegeben
  6935.           { if (!nullp(ThePathname(STACK_0)->pathname_type))
  6936.               { # STACK_0 = Wert für Slot PATHNAME von FILE-ERROR
  6937.                 pushSTACK(STACK_0); # pathname
  6938.                 pushSTACK(TheSubr(subr_self)->name);
  6939.                 //: DEUTSCH "~: Pathname mit TYPE, aber ohne NAME sinnlos: ~"
  6940.                 //: ENGLISH "~: pathname with type but without name makes no sense: ~"
  6941.                 //: FRANCAIS "~ : Un PATHNAME avec TYPE mais sans NAME est insensé: ~"
  6942.                 fehler(file_error, GETTEXT("~: pathname with type but without name makes no sense: ~"));
  6943.               }
  6944.             # Kein Name und kein Typ angegeben -> pathname als Ergebnis
  6945.           }
  6946.           else
  6947.           # Name angegeben.
  6948.           { # Überprüfe, ob die Datei existiert:
  6949.             if_file_exists(namestring, ; , { fehler_file_not_exists(); } );
  6950.             # Datei existiert -> Pathname als Wert
  6951.           }
  6952.         value1 = popSTACK();
  6953.       }}
  6954.     mv_count=1;
  6955.   }
  6956.  
  6957. LISPFUNN(probe_file,1)
  6958. # (PROBE-FILE filename), CLTL S. 424
  6959.   { var reg1 object pathname = popSTACK(); # pathname-Argument
  6960.     if (streamp(pathname))
  6961.       # Stream -> extra behandeln:
  6962.       { # muß File-Stream sein:
  6963.         pathname = as_file_stream(pathname);
  6964.         # Streamtyp File-Stream -> Truename nehmen:
  6965.        {var reg1 uintB flags = TheStream(pathname)->strmflags;
  6966.         pathname = TheStream(pathname)->strm_file_truename;
  6967.         if (flags & strmflags_open_B) # Datei geöffnet ?
  6968.           # ja -> Truename sofort als Ergebnis:
  6969.           { value1 = pathname; mv_count=1; return; }
  6970.         # nein -> noch testen, ob die Datei zum Truename existiert.
  6971.       }}
  6972.       else
  6973.       { pathname = coerce_pathname(pathname); } # zu einem Pathname machen
  6974.     # pathname ist jetzt ein Pathname.
  6975.     check_no_wildcards(pathname); # mit Wildcards -> Fehler
  6976.     pathname = use_default_dir(pathname); # Default-Directory einfügen
  6977.     if (namenullp(pathname)) { fehler_noname(pathname); } # Kein Name angegeben -> Fehler
  6978.     # Name angegeben.
  6979.     pushSTACK(pathname);
  6980.    {# Directory muß existieren:
  6981.     var reg3 object namestring = assure_dir_exists_(TRUE,TRUE); # Filename als ASCIZ-String
  6982.     if (eq(namestring,nullobj))
  6983.       # Pfad zur Datei existiert nicht -> NIL als Wert:
  6984.       { skipSTACK(1); value1 = NIL; mv_count=1; return; }
  6985.     # Überprüfe, ob die Datei existiert:
  6986.     if_file_exists(namestring,
  6987.       { value1 = popSTACK(); mv_count=1; }, # Datei existiert -> Pathname als Wert
  6988.       { skipSTACK(1); value1 = NIL; mv_count=1; return; } # sonst NIL als Wert
  6989.       );
  6990.   }}
  6991.  
  6992. # UP: Stellt fest, ob eine Datei geöffnet ist.
  6993. # openp(pathname)
  6994. #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  6995. # > pathname: absoluter Pathname, ohne Wildcards.
  6996. #endif
  6997. #ifdef PATHNAME_AMIGAOS
  6998. # > pathname: absoluter Pathname, ohne Wildcards, ohne :PARENT
  6999. #endif
  7000. #ifdef PATHNAME_UNIX
  7001. # > pathname: absoluter Pathname, ohne Wildcards, nach Auflösung
  7002. #             symbolischer Links
  7003. #endif
  7004. # < ergebnis: TRUE, falls ein geöffneter File-Stream auf diese Datei existiert.
  7005.   local boolean openp (object pathname);
  7006.   local boolean openp(pathname)
  7007.     var reg2 object pathname;
  7008.     { var reg1 object flist = O(open_files); # Liste aller offenen Files durchlaufen
  7009.       while (consp(flist))
  7010.         { var reg3 object f = Car(flist); # nächster offener Stream
  7011.           if_strm_file_p(f, # File-Stream ?
  7012.             { if (equal(TheStream(f)->strm_file_truename,pathname))
  7013.                 { return TRUE; }
  7014.             },
  7015.             ; );
  7016.           flist = Cdr(flist);
  7017.         }
  7018.       return FALSE;
  7019.     }
  7020.  
  7021. # Fehlermeldung wegen Löschversuch auf geöffnete Datei
  7022. # fehler_delete_open(pathname);
  7023. # > pathname: Truename der Datei
  7024.   nonreturning_function(local, fehler_delete_open, (object pathname));
  7025.   local void fehler_delete_open(pathname)
  7026.     var reg1 object pathname;
  7027.     { pushSTACK(pathname); # Wert für Slot PATHNAME von FILE-ERROR
  7028.       pushSTACK(pathname);
  7029.       //: DEUTSCH "Datei ~ kann nicht gelöscht werden, weil ein File-Stream auf sie geöffnet wurde."
  7030.       //: ENGLISH "cannot delete file ~ since there is file stream open to it"
  7031.       //: FRANCAIS "Le fichier ~ ne peut pas être effacé car il est encore ouvert comme «stream»."
  7032.       fehler(file_error, GETTEXT("cannot delete file ~ since there is file stream open to it"));
  7033.     }
  7034.  
  7035. LISPFUNN(delete_file,1)
  7036. # (DELETE-FILE filename), CLTL S. 424
  7037.   { var reg1 object pathname = popSTACK(); # pathname-Argument
  7038.     if (streamp(pathname))
  7039.       # Stream -> extra behandeln:
  7040.       { var object stream = as_file_stream(pathname); # muß File-Stream sein
  7041.         # Streamtyp File-Stream.
  7042.         # Falls Datei geöffnet, erst Datei schließen:
  7043.         if (TheStream(stream)->strmflags & strmflags_open_B) # Datei geöffnet ?
  7044.           { stream_close(&stream); }
  7045.         # Dann den Truename als zu löschende Datei nehmen:
  7046.         pathname = TheStream(stream)->strm_file_truename;
  7047.       }
  7048.       else
  7049.       { pathname = coerce_pathname(pathname); } # zu einem Pathname machen
  7050.     # pathname ist jetzt ein Pathname.
  7051.     check_no_wildcards(pathname); # mit Wildcards -> Fehler
  7052.     pathname = use_default_dir(pathname); # Default-Directory einfügen
  7053.     if (namenullp(pathname)) { fehler_noname(pathname); } # Kein Name angegeben -> Fehler
  7054.     # Name angegeben.
  7055.     pushSTACK(pathname);
  7056.    {# Directory muß existieren:
  7057.     var reg3 object namestring = assure_dir_exists(TRUE); # Filename als ASCIZ-String
  7058.     if (eq(namestring,nullobj))
  7059.       # Pfad zur Datei existiert nicht -> Wert NIL
  7060.       { skipSTACK(1); value1 = NIL; mv_count=1; return; }
  7061.     if (openp(STACK_0)) { fehler_delete_open(STACK_0); } # Keine offenen Dateien löschen!
  7062.     # Datei löschen:
  7063.     #ifdef AMIGAOS
  7064.     if (!file_exists(namestring))
  7065.       { skipSTACK(1); value1 = NIL; mv_count=1; return; } # File existiert nicht -> Wert NIL
  7066.     begin_system_call();
  7067.     if (! DeleteFile(TheAsciz(namestring)) ) { OS_error(); }
  7068.     end_system_call();
  7069.     #endif
  7070.     #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_DOS) || defined(WIN32_UNIX)
  7071.     begin_system_call();
  7072.     if (!( unlink(TheAsciz(namestring)) ==0))
  7073.       { if (!(errno==ENOENT)) { OS_error(); }
  7074.         end_system_call();
  7075.         # File existiert nicht -> Wert NIL
  7076.         skipSTACK(1); value1 = NIL; mv_count=1; return;
  7077.       }
  7078.     end_system_call();
  7079.     #endif
  7080.     # Datei existierte, wurde gelöscht -> Pathname (/=NIL) als Wert
  7081.     value1 = popSTACK(); mv_count=1;
  7082.   }}
  7083.  
  7084. # Fehlermeldung wegen Umbenennungsversuch einer geöffneten Datei
  7085. # fehler_rename_open(pathname);
  7086. # > pathname: Truename der Datei
  7087.   nonreturning_function(local, fehler_rename_open, (object pathname));
  7088.   local void fehler_rename_open(pathname)
  7089.     var reg1 object pathname;
  7090.     { pushSTACK(pathname); # Wert für Slot PATHNAME von FILE-ERROR
  7091.       pushSTACK(pathname);
  7092.       //: DEUTSCH "Datei ~ kann nicht umbenannt werden, weil ein File-Stream auf sie geöffnet wurde."
  7093.       //: ENGLISH "cannot rename file ~ since there is file stream open to it"
  7094.       //: FRANCAIS "Le fichier ~ ne peut pas être renommé car il est encore ouvert comme «stream»."
  7095.       fehler(file_error, GETTEXT("cannot rename file ~ since there is file stream open to it"));
  7096.     }
  7097.  
  7098. # UP: Führt eine Datei-Umbenennung durch.
  7099. # rename_file();
  7100. # > Stackaufbau: filename, newname, oldpathname.
  7101. # < Stackaufbau: filename, newname, oldpathname, newpathname,
  7102. #                oldtruename, oldnamestring, newtruename, newnamestring.
  7103.   local void rename_file (void);
  7104.   local void rename_file()
  7105.     { # 1. newpathname := (MERGE-PATHNAMES newname oldpathname)
  7106.       { pushSTACK(STACK_1); # newname als 1. Argument
  7107.         pushSTACK(STACK_(0+1)); # oldpathname als 2. Argument
  7108.         funcall(L(merge_pathnames),2);
  7109.         pushSTACK(value1);
  7110.       }
  7111.       # Stackaufbau: filename, newname, oldpathname, newpathname.
  7112.       # 2. oldpathname überprüfen:
  7113.       { var reg1 object oldpathname = STACK_1;
  7114.         check_no_wildcards(oldpathname); # mit Wildcards -> Fehler
  7115.         oldpathname = use_default_dir(oldpathname); # Default-Directory einfügen
  7116.         if (namenullp(oldpathname)) { fehler_noname(oldpathname); } # Kein Name angegeben -> Fehler
  7117.         # Name angegeben.
  7118.         pushSTACK(oldpathname);
  7119.        {# Directory muß existieren:
  7120.         var reg2 object old_namestring = assure_dir_exists(FALSE); # Filename als ASCIZ-String
  7121.         if (openp(STACK_0)) { fehler_rename_open(STACK_0); } # Keine offenen Dateien umbenennen!
  7122.         pushSTACK(old_namestring);
  7123.       }}
  7124.       # Stackaufbau: filename, newname, oldpathname, newpathname,
  7125.       #              oldtruename, oldnamestring.
  7126.       # 3. newpathname überprüfen:
  7127.       { var reg1 object newpathname = coerce_pathname(STACK_2);
  7128.         check_no_wildcards(newpathname); # mit Wildcards -> Fehler
  7129.         newpathname = use_default_dir(newpathname); # Default-Directory einfügen
  7130.         if (namenullp(newpathname)) { fehler_noname(newpathname); } # Kein Name angegeben -> Fehler
  7131.         # Name angegeben.
  7132.         pushSTACK(newpathname);
  7133.        {# Directory muß existieren:
  7134.         var reg2 object new_namestring = assure_dir_exists(FALSE); # Filename als ASCIZ-String
  7135.         pushSTACK(new_namestring);
  7136.       }}
  7137.       # Stackaufbau: filename, newname, oldpathname, newpathname,
  7138.       #              oldtruename, oldnamestring, newtruename, newnamestring.
  7139.       # 4. Datei umbenennen:
  7140.       #if defined(UNIX) || defined(AMIGAOS) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_DOS) || defined(WIN32_UNIX)
  7141.       #if 0
  7142.       if (file_exists(STACK_0))
  7143.         # Datei existiert bereits -> nicht ohne Vorwarnung löschen
  7144.         { fehler_file_exists(S(rename_file),STACK_1); }
  7145.       #endif
  7146.       # Nun kann gefahrlos umbenannt werden:
  7147.       #ifdef PATHNAME_RISCOS
  7148.       prepare_create(STACK_4);
  7149.       #endif
  7150.       begin_system_call();
  7151.       #ifdef AMIGAOS
  7152.       if (! Rename(TheAsciz(STACK_2),TheAsciz(STACK_0)) ) { OS_error(); }
  7153.       #endif
  7154.       #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_DOS) || defined(WIN32_UNIX)
  7155.       if (!( rename(TheAsciz(STACK_2),TheAsciz(STACK_0)) ==0)) { OS_error(); }
  7156.       #endif
  7157.       end_system_call();
  7158.       #endif
  7159.     }
  7160.  
  7161. LISPFUNN(rename_file,2)
  7162. # (RENAME-FILE filename newname), CLTL S. 423
  7163.   { var reg1 object filename = STACK_1; # filename-Argument
  7164.     if (streamp(filename))
  7165.       # Stream -> extra behandeln:
  7166.       { # muß File-Stream sein:
  7167.         filename = as_file_stream(filename);
  7168.         # Streamtyp File-Stream -> Truename verwenden:
  7169.         filename = TheStream(filename)->strm_file_truename;
  7170.         pushSTACK(filename);
  7171.         # Umbenennen:
  7172.         rename_file();
  7173.         # Stream aktualisieren:
  7174.         filename = STACK_7;
  7175.         TheStream(filename)->strm_file_name = STACK_4; # newpathname als neuer Name
  7176.         TheStream(filename)->strm_file_truename = STACK_1; # newtruename als neuer Truename
  7177.         # Handle etc. unverändert lassen
  7178.       }
  7179.       else
  7180.       { filename = coerce_pathname(filename); # zu einem Pathname machen
  7181.         pushSTACK(filename);
  7182.         # Umbenennen:
  7183.         rename_file();
  7184.       }
  7185.     value1 = STACK_4; # newpathname als 1. Wert
  7186.     value2 = STACK_3; # oldtruename als 2. Wert
  7187.     value3 = STACK_1; # newtruename als 3. Wert
  7188.     mv_count=3; skipSTACK(8); # 3 Werte
  7189.   }
  7190.  
  7191. # UP: erzeugt ein File-Stream
  7192. # open_file(filename,direction,if_exists,if_not_exists,type,eltype_size)
  7193. # > filename: Filename, ein Pathname
  7194. # > direction: Modus (0 = :PROBE, 1 = :INPUT, 4 = :OUTPUT, 5 = :IO, 3 = :INPUT-IMMUTABLE)
  7195. # > if_exists: :IF-EXISTS-Argument
  7196. #         (0 = nichts, 1 = :ERROR, 2 = NIL,
  7197. #          3 = :RENAME, 4 = :RENAME-AND-DELETE, 5 = :NEW-VERSION,:SUPERSEDE,
  7198. #          6 = :APPEND, 7 = :OVERWRITE)
  7199. # > if_not_exists: :IF-DOES-NOT-EXIST-Argument
  7200. #         (0 = nichts, 1 = :ERROR, 2 = NIL, 3 = :CREATE)
  7201. # > type: nähere Typinfo
  7202. #         (STRMTYPE_SCH_FILE oder STRMTYPE_CH_FILE oder
  7203. #          STRMTYPE_IU_FILE oder STRMTYPE_IS_FILE)
  7204. # > eltype_size: (bei Integer-Streams) Größe der Elemente in Bits,
  7205. #         ein Fixnum >0 und <intDsize*uintC_max
  7206. # < ergebnis: Stream oder NIL
  7207. # kann GC auslösen
  7208.   local object open_file (object filename, uintB direction, uintB if_exists, uintB if_not_exists,
  7209.                           uintB type, object eltype_size);
  7210.   local object open_file(filename,direction,if_exists,if_not_exists,type,eltype_size)
  7211.     var reg5 object filename;
  7212.     var reg8 uintB direction;
  7213.     var reg3 uintB if_exists;
  7214.     var reg4 uintB if_not_exists;
  7215.     var reg7 uintB type;
  7216.     var reg9 object eltype_size;
  7217.     { pushSTACK(filename); # Filename retten
  7218.       check_no_wildcards(filename); # mit Wildcards -> Fehler
  7219.       filename = use_default_dir(filename); # Default-Directory einfügen
  7220.       if (namenullp(filename)) { fehler_noname(filename); } # Kein Name angegeben -> Fehler
  7221.       pushSTACK(filename); # absPathname retten
  7222.       # Stackaufbau: Pathname, absPathname.
  7223.       { # Directory muß existieren:
  7224.         var reg3 object namestring = # Filename als ASCIZ-String
  7225.           assure_dir_exists((direction == 0) && ((if_not_exists % 2) == 0)); # tolerant nur bei :PROBE und if_not_exists = 0 oder 2
  7226.         # Stackaufbau: Pathname, Truename.
  7227.         # Filename überprüfen und Handle holen:
  7228.         var reg2 object handle;
  7229.         var reg6 boolean append_flag = FALSE;
  7230.         switch (direction)
  7231.           { case 0: # Modus ist :PROBE
  7232.               if (eq(namestring,nullobj))
  7233.                 # Pfad zur Datei existiert nicht, und :IF-DOES-NOT-EXIST = nichts oder NIL
  7234.                 goto ergebnis_NIL;
  7235.               #if defined(UNIX) || defined(AMIGAOS) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_DOS) || defined(WIN32_UNIX)
  7236.               if (!file_exists(namestring))
  7237.                 # Datei existiert nicht
  7238.                 { # :IF-DOES-NOT-EXIST-Argument entscheidet:
  7239.                   if (if_not_exists==1) # :ERROR -> Error
  7240.                     goto fehler_notfound;
  7241.                   if (!(if_not_exists==3)) # nichts oder NIL -> NIL
  7242.                     goto ergebnis_NIL;
  7243.                   #ifdef PATHNAME_RISCOS
  7244.                   pushSTACK(namestring); prepare_create(STACK_1); namestring = popSTACK();
  7245.                   #endif
  7246.                  {# :CREATE -> Datei mit open erzeugen und schließen:
  7247.                   #ifdef AMIGAOS
  7248.                   var reg1 Handle handle;
  7249.                   begin_system_call();
  7250.                   handle = Open(TheAsciz(namestring),MODE_NEWFILE);
  7251.                   if (handle == Handle_NULL) { OS_error(); } # Error melden
  7252.                   # Datei wurde erzeugt, handle ist das Handle.
  7253.                   # Datei wieder schließen:
  7254.                   (void) Close(handle);
  7255.                   end_system_call();
  7256.                   #endif
  7257.                   #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_DOS) || defined(WIN32_UNIX)
  7258.                   var reg1 int ergebnis;
  7259.                   begin_system_call();
  7260.                   #if defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(WIN32_DOS)
  7261.                   ergebnis = creat(TheAsciz(namestring),my_open_mask);
  7262.                   if (ergebnis<0) { OS_error(); } # Error melden
  7263.                   setmode(ergebnis,O_BINARY);
  7264.                   #endif
  7265.                   #if defined(UNIX) || defined(RISCOS) || defined(WIN32_UNIX)
  7266.                   ergebnis = OPEN(TheAsciz(namestring),
  7267.                                   O_WRONLY | O_CREAT | O_TRUNC,
  7268.                                   my_open_mask
  7269.                                  );
  7270.                   if (ergebnis<0) { OS_error(); } # Error melden
  7271.                   #ifdef WIN32_UNIX
  7272.                   setmode(ergebnis,O_BINARY);
  7273.                   #endif
  7274.                   #endif
  7275.                   # Datei wurde erzeugt, ergebnis ist das Handle.
  7276.                   # Datei wieder schließen:
  7277.                   ergebnis = CLOSE(ergebnis);
  7278.                   if (!(ergebnis==0)) { OS_error(); } # Error melden
  7279.                   end_system_call();
  7280.                   #endif
  7281.                 }}
  7282.               handle = NIL; # Handle := NIL
  7283.               break;
  7284.               #endif
  7285.             case 1: case 3: # Modus ist :INPUT
  7286.               #if defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(WIN32_DOS)
  7287.               { # erst mit open erfragen, ob die Datei existiert:
  7288.                 var reg1 sintW ergebnis;
  7289.                 # Datei zu öffnen versuchen:
  7290.                 begin_system_call();
  7291.                 ergebnis = open(TheAsciz(namestring),O_RDONLY);
  7292.                 if (ergebnis<0)
  7293.                   { if (errno == ENOENT) # nicht gefunden?
  7294.                       # Datei existiert nicht
  7295.                       { # :IF-DOES-NOT-EXIST-Argument entscheidet:
  7296.                         if (if_not_exists==2) # NIL -> NIL
  7297.                           goto ergebnis_NIL;
  7298.                         if (!(if_not_exists==3)) # nichts oder :ERROR -> Error
  7299.                           goto fehler_notfound;
  7300.                         # :CREATE -> Datei mit creat erzeugen:
  7301.                         ergebnis = creat(TheAsciz(namestring),my_open_mask);
  7302.                         if (ergebnis<0) { OS_error(); }
  7303.                       }
  7304.                       else
  7305.                       { OS_error(); } # sonstigen Error melden
  7306.                   }
  7307.                 setmode(ergebnis,O_BINARY);
  7308.                 end_system_call();
  7309.                 # Datei existiert, ergebnis ist das Handle
  7310.                 handle = allocate_handle(ergebnis); # Handle
  7311.                 break;
  7312.               }
  7313.               #endif
  7314.               #ifdef AMIGAOS
  7315.               { # erst mit Open erfragen, ob die Datei existiert:
  7316.                 var reg1 Handle handl;
  7317.                 begin_system_call();
  7318.                 handl = Open(TheAsciz(namestring),MODE_OLDFILE);
  7319.                 if (handl==Handle_NULL)
  7320.                   { if (IoErr()==ERROR_OBJECT_NOT_FOUND)
  7321.                       # Datei existiert nicht
  7322.                       { # :IF-DOES-NOT-EXIST-Argument entscheidet:
  7323.                         if (if_not_exists==2) # NIL -> NIL
  7324.                           goto ergebnis_NIL;
  7325.                         if (!(if_not_exists==3)) # nichts oder :ERROR -> Error
  7326.                           goto fehler_notfound;
  7327.                         # :CREATE -> Datei mit Open erzeugen:
  7328.                         handl = Open(TheAsciz(namestring),MODE_READWRITE);
  7329.                   }   }
  7330.                 if (handl==Handle_NULL) { OS_error(); } # Error melden
  7331.                 end_system_call();
  7332.                 # Datei existiert, handle ist das Handle
  7333.                 handle = allocate_handle(handl); # Handle als Lisp-Objekt
  7334.                 break;
  7335.               }
  7336.               #endif
  7337.               #if defined(UNIX) || defined(RISCOS) || defined(WIN32_UNIX)
  7338.               { var reg2 int o_flags = O_RDONLY;
  7339.                 if (!file_exists(namestring))
  7340.                   # Datei existiert nicht
  7341.                   { # :IF-DOES-NOT-EXIST-Argument entscheidet:
  7342.                     if (if_not_exists==2) # NIL -> NIL
  7343.                       goto ergebnis_NIL;
  7344.                     if (!(if_not_exists==3)) # nichts oder :ERROR -> Error
  7345.                       goto fehler_notfound;
  7346.                     # :CREATE -> Datei mit open erzeugen
  7347.                     #ifdef PATHNAME_RISCOS
  7348.                     pushSTACK(namestring); prepare_create(STACK_1); namestring = popSTACK();
  7349.                     #endif
  7350.                     o_flags |= O_CREAT;
  7351.                   }
  7352.                {var reg1 int ergebnis;
  7353.                 begin_system_call();
  7354.                 ergebnis = OPEN(TheAsciz(namestring),
  7355.                                 o_flags, # O_RDONLY bzw. O_RDONLY | O_CREAT
  7356.                                 my_open_mask
  7357.                                );
  7358.                 if (ergebnis<0) { OS_error(); } # Error melden
  7359.                 #ifdef WIN32_UNIX
  7360.                 setmode(ergebnis,O_BINARY);
  7361.                 #endif
  7362.                 end_system_call();
  7363.                 # Datei existiert, ergebnis ist das Handle
  7364.                 handle = allocate_handle(ergebnis); # Handle
  7365.               }}
  7366.               break;
  7367.               #endif
  7368.             default: # Modus ist :OUTPUT oder :IO
  7369.               { # Defaultwert für if_not_exists ist von if_exists abhängig:
  7370.                 if (if_not_exists==0) # falls if_not_exists nicht angegeben:
  7371.                   { if (if_exists<6) # if_exists = :APPEND oder :OVERWRITE -> if_not_exists unverändert
  7372.                       { if_not_exists = 3; } # weder :APPEND noch :OVERWRITE -> Default ist :CREATE
  7373.                   }
  7374.                 # Defaultwert für if_exists ist :NEW-VERSION :
  7375.                 if (if_exists==0) { if_exists = 5; }
  7376.                 #if defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(WIN32_DOS)
  7377.                 # Bei if_exists=5 und if_not_exists=3 kann man sofort
  7378.                 # CREAT ansteuern, sonst muß man vorher OPEN versuchen:
  7379.                 if (!((if_exists==5) && (if_not_exists==3)))
  7380.                   { begin_system_call();
  7381.                    {var reg1 sintW ergebnis = # Datei zu öffnen versuchen
  7382.                       open(TheAsciz(namestring),O_RDWR);
  7383.                     if (ergebnis<0)
  7384.                       { end_system_call();
  7385.                         if (errno == ENOENT) # nicht gefunden?
  7386.                           # Datei existiert nicht
  7387.                           { # :IF-DOES-NOT-EXIST-Argument entscheidet:
  7388.                             if (if_not_exists<2) # (Default bei :APPEND oder :OVERWRITE) oder :ERROR ?
  7389.                               goto fehler_notfound;
  7390.                             if (if_not_exists==2) # NIL -> NIL
  7391.                               goto ergebnis_NIL;
  7392.                             # :CREATE
  7393.                           }
  7394.                           else
  7395.                           { OS_error(); } # sonstigen Error melden
  7396.                       }
  7397.                       else
  7398.                       # Datei existiert, ergebnis ist das Handle
  7399.                       { # :IF-EXISTS-Argument entscheidet:
  7400.                         switch (if_exists)
  7401.                           { case 1: # :ERROR -> schließen und Error
  7402.                               { if (CLOSE(ergebnis) < 0) { OS_error(); } # Error melden
  7403.                                 end_system_call();
  7404.                                 goto fehler_exists;
  7405.                               }
  7406.                             case 2: # NIL -> schließen und NIL
  7407.                               { if (CLOSE(ergebnis) < 0) { OS_error(); } # Error melden
  7408.                                 end_system_call();
  7409.                                 goto ergebnis_NIL;
  7410.                               }
  7411.                             case 6: # :APPEND
  7412.                               append_flag = TRUE; # am Schluß ans Ende positionieren
  7413.                             case 7: # :OVERWRITE -> bestehende Datei benutzen
  7414.                               setmode(ergebnis,O_BINARY);
  7415.                               end_system_call();
  7416.                               handle = allocate_handle(ergebnis);
  7417.                               goto handle_ok;
  7418.                             default: ;
  7419.                               # :RENAME, :RENAME-AND-DELETE -> Datei umbenennen und dann neu eröffnen.
  7420.                               # :NEW-VERSION, :SUPERSEDE -> Datei auf Länge 0 kürzen.
  7421.                           }
  7422.                         # In beiden Fällen erst die Datei schließen:
  7423.                         if (CLOSE(ergebnis) < 0) { OS_error(); } # Error melden
  7424.                         end_system_call();
  7425.                         if ((if_exists==3) || (if_exists==4))
  7426.                           # :RENAME oder :RENAME-AND-DELETE -> umbenennen:
  7427.                           { # Truename mit ".BAK" erweitern:
  7428.                             var reg1 object filename = STACK_0;
  7429.                             if (openp(filename)) { fehler_rename_open(filename); } # Keine offenen Dateien umbenennen!
  7430.                             pushSTACK(namestring); # namestring retten
  7431.                             # filename := (merge-pathnames ".BAK" filename) :
  7432.                             filename = copy_pathname(filename); # kopieren
  7433.                             ThePathname(filename)->pathname_type = O(backuptype_string); # mit Extension "BAK"
  7434.                             if (openp(filename)) { fehler_delete_open(filename); } # Keine offenen Dateien löschen!
  7435.                             pushSTACK(filename);
  7436.                            {# Directory existiert schon:
  7437.                             var reg3 object new_namestring = assume_dir_exists(); # Filename als ASCIZ-String
  7438.                             # Datei mit diesem Namen löschen, falls vorhanden:
  7439.                             begin_system_call();
  7440.                             if ( unlink(TheAsciz(new_namestring)) <0) # Datei zu löschen versuchen
  7441.                               { if (!(errno==ENOENT)) # nicht gefunden -> OK
  7442.                                   { OS_error(); } # sonstigen Error melden
  7443.                               }
  7444.                             end_system_call();
  7445.                             # Datei vom alten auf diesen Namen umbenennen:
  7446.                             skipSTACK(1);
  7447.                             namestring = popSTACK(); # namestring zurück
  7448.                             begin_system_call();
  7449.                             if ( rename(TheAsciz(namestring),TheAsciz(new_namestring)) <0) # Datei umbenennen
  7450.                               { OS_error(); } # Error melden
  7451.                             end_system_call();
  7452.                             # :RENAME-AND-DELETE -> löschen:
  7453.                             if (if_exists==4)
  7454.                               { begin_system_call();
  7455.                                 if ( unlink(TheAsciz(new_namestring)) <0)
  7456.                                   { OS_error(); } # Error melden
  7457.                                 end_system_call();
  7458.                               }
  7459.                           }}
  7460.                       }
  7461.                   }}
  7462.                 # Datei mit CREAT erzeugen:
  7463.                 begin_system_call();
  7464.                 { var reg1 sintW ergebnis = # erzeugen
  7465.                     creat(TheAsciz(namestring),my_open_mask);
  7466.                   if (ergebnis<0) { OS_error(); } # Error melden
  7467.                   #if defined(WIN32_DOS) && 0
  7468.                   CLOSE(ergebnis);
  7469.                   ergebnis = open(TheAsciz(namestring), O_RDWR);
  7470.                   #endif
  7471.                   setmode(ergebnis,O_BINARY);
  7472.                   end_system_call();
  7473.                   # Datei neu erzeugt, ergebnis ist das Handle
  7474.                   handle = allocate_handle(ergebnis);
  7475.                 }
  7476.                 #endif
  7477.                 #if defined(UNIX) || defined(AMIGAOS) || defined(RISCOS) || defined(WIN32_UNIX)
  7478.                 if (file_exists(namestring))
  7479.                   # Datei existiert
  7480.                   { # :IF-EXISTS-Argument entscheidet:
  7481.                     switch (if_exists)
  7482.                       { case 1: # :ERROR -> Error
  7483.                           goto fehler_exists;
  7484.                         case 2: # NIL -> NIL
  7485.                           goto ergebnis_NIL;
  7486.                         case 3: case 4: # :RENAME oder :RENAME-AND-DELETE -> umbenennen:
  7487.                           #if defined(UNIX) || defined(AMIGAOS) || defined(RISCOS)
  7488.                           { # Truename mit "%" bzw. ".bak" bzw. "~" erweitern:
  7489.                             var reg1 object filename = STACK_0;
  7490.                             var reg3 object new_namestring;
  7491.                             if (openp(filename)) { fehler_rename_open(filename); } # Keine offenen Dateien umbenennen!
  7492.                             pushSTACK(namestring); # namestring retten
  7493.                             #if defined(UNIX) || defined(AMIGAOS) || defined(WIN32_UNIX)
  7494.                             # filename := (parse-namestring (concatenate 'string (namestring filename) "%")) :
  7495.                             filename = whole_namestring(filename); # als String
  7496.                             pushSTACK(filename); pushSTACK(O(backupextend_string)); # "%"
  7497.                             filename = string_concat(2); # dazuhängen
  7498.                             pushSTACK(filename); # retten
  7499.                             filename = coerce_pathname(filename); # wieder als Filename
  7500.                             if (openp(filename)) { fehler_delete_open(filename); } # Keine offenen Dateien löschen!
  7501.                             # Directory existiert schon. Hier keine weiteren Links verfolgen.
  7502.                             new_namestring = string_to_asciz(popSTACK()); # Filename als ASCIZ-String
  7503.                             #endif
  7504.                             #ifdef RISCOS
  7505.                             # Dem Namen ein "~" voranstellen:
  7506.                             filename = copy_pathname(filename);
  7507.                             pushSTACK(filename);
  7508.                             pushSTACK(O(backupprepend_string)); pushSTACK(ThePathname(filename)->pathname_name);
  7509.                             { var reg1 object new_name = string_concat(2);
  7510.                               filename = STACK_0;
  7511.                               ThePathname(filename)->pathname_name = new_name;
  7512.                             }
  7513.                             if (openp(filename)) { fehler_delete_open(filename); } # Keine offenen Dateien löschen!
  7514.                             new_namestring = assure_dir_exists(FALSE);
  7515.                             skipSTACK(1);
  7516.                             #endif
  7517.                             # Datei (oder Link) mit diesem Namen löschen, falls vorhanden:
  7518.                             #if defined(AMIGAOS)
  7519.                             begin_system_call();
  7520.                             if (! DeleteFile(TheAsciz(new_namestring)) )
  7521.                               { if (!(IoErr()==ERROR_OBJECT_NOT_FOUND)) { OS_error(); } # Error melden
  7522.                                 # nicht gefunden -> OK
  7523.                               }
  7524.                             end_system_call();
  7525.                             #endif
  7526.                             #if (defined(UNIX) && 0) || defined(RISCOS) # Das tut UNIX nachher automatisch, RISCOS aber nicht
  7527.                             begin_system_call();
  7528.                             if (!( unlink(TheAsciz(new_namestring)) ==0))
  7529.                               { if (!(errno==ENOENT)) { OS_error(); } # Error melden
  7530.                                 # nicht gefunden -> OK
  7531.                               }
  7532.                             end_system_call();
  7533.                             #endif
  7534.                             # Datei vom alten auf diesen Namen umbenennen:
  7535.                             namestring = popSTACK(); # namestring zurück
  7536.                             begin_system_call();
  7537.                             #ifdef AMIGAOS
  7538.                             if (! Rename(TheAsciz(namestring),TheAsciz(new_namestring)) )
  7539.                               { OS_error(); }
  7540.                             #endif
  7541.                             #if defined(UNIX) || defined(RISCOS)
  7542.                             if (!( rename(TheAsciz(namestring),TheAsciz(new_namestring)) ==0))
  7543.                               { OS_error(); }
  7544.                             #endif
  7545.                             # :RENAME-AND-DELETE -> löschen:
  7546.                             if (if_exists==4)
  7547.                               {
  7548.                                 #ifdef AMIGAOS
  7549.                                 if (! DeleteFile(TheAsciz(new_namestring)) )
  7550.                                   { OS_error(); }
  7551.                                 #endif
  7552.                                 #if defined(UNIX) || defined(RISCOS)
  7553.                                 if (!( unlink(TheAsciz(new_namestring)) ==0))
  7554.                                   { OS_error(); }
  7555.                                 #endif
  7556.                               }
  7557.                             end_system_call();
  7558.                           }
  7559.                           #endif
  7560.                           break;
  7561.                         case 6: # :APPEND
  7562.                           append_flag = TRUE; # am Schluß ans Ende positionieren
  7563.                         default: ;
  7564.                           # :OVERWRITE -> bestehende Datei benutzen
  7565.                           # :NEW-VERSION, :SUPERSEDE -> Datei auf Länge 0 kürzen.
  7566.                   }   }
  7567.                   else
  7568.                   # Datei existiert nicht
  7569.                   { # :IF-DOES-NOT-EXIST-Argument entscheidet:
  7570.                     if (if_not_exists<2) # (Default bei :APPEND oder :OVERWRITE) oder :ERROR ?
  7571.                       goto fehler_notfound;
  7572.                     if (if_not_exists==2) # NIL -> NIL
  7573.                       goto ergebnis_NIL;
  7574.                     # :CREATE
  7575.                   }
  7576.                 #ifdef PATHNAME_RISCOS
  7577.                 pushSTACK(namestring); prepare_create(STACK_1); namestring = popSTACK();
  7578.                 #endif
  7579.                 # Datei mit open öffnen:
  7580.                 { # if-exists-Handling: bei if_exists<=5 Inhalt löschen,
  7581.                   # sonst (bei :APPEND, :OVERWRITE) bestehenden Inhalt lassen.
  7582.                   # if-not-exists-Handling: neue Datei erzeugen.
  7583.                   #ifdef AMIGAOS
  7584.                   var reg1 Handle handl;
  7585.                   begin_system_call();
  7586.                   handl = Open(TheAsciz(namestring),
  7587.                                (if_exists<=5 ? MODE_NEWFILE : MODE_READWRITE)
  7588.                               );
  7589.                   if (handl==Handle_NULL) { OS_error(); } # Error melden
  7590.                   end_system_call();
  7591.                   handle = allocate_handle(handl);
  7592.                   #endif
  7593.                   #if defined(UNIX) || defined(RISCOS) || defined(WIN32_UNIX)
  7594.                   var reg1 int ergebnis;
  7595.                   begin_system_call();
  7596.                   ergebnis = OPEN(TheAsciz(namestring),
  7597.                                   (if_exists<=5 ? O_RDWR | O_CREAT | O_TRUNC
  7598.                                                 : O_RDWR | O_CREAT
  7599.                                   ),
  7600.                                   my_open_mask
  7601.                                  );
  7602.                   if (ergebnis<0) { OS_error(); } # Error melden
  7603.                   #ifdef WIN32_UNIX
  7604.                   setmode(ergebnis,O_BINARY);
  7605.                   #endif
  7606.                   end_system_call();
  7607.                   # Datei wurde geöffnet, ergebnis ist das Handle.
  7608.                   handle = allocate_handle(ergebnis);
  7609.                   #endif
  7610.                 }
  7611.                 #endif
  7612.                 break;
  7613.               }
  7614.             ergebnis_NIL: # Ergebnis NIL
  7615.               skipSTACK(2); # beide Pathnames vergessen
  7616.               return NIL;
  7617.             fehler_notfound: # Fehler, da Datei nicht gefunden
  7618.               # STACK_0 = Truename, Wert für Slot PATHNAME von FILE-ERROR
  7619.               pushSTACK(STACK_0);
  7620.               //: DEUTSCH "Eine Datei mit Namen ~ existiert nicht."
  7621.               //: ENGLISH "file ~ does not exist"
  7622.               //: FRANCAIS "Un fichier de nom ~ n'existe pas."
  7623.               fehler(file_error, GETTEXT("file ~ does not exist"));
  7624.             fehler_exists: # Fehler, da Datei bereits existiert
  7625.               # STACK_0 = Truename, Wert für Slot PATHNAME von FILE-ERROR
  7626.               pushSTACK(STACK_0);
  7627.               //: DEUTSCH "Eine Datei mit Namen ~ existiert bereits."
  7628.               //: ENGLISH "a file named ~ already exists"
  7629.               //: FRANCAIS "Un fichier de nom ~ existe déjà."
  7630.               fehler(file_error, GETTEXT("a file named ~ already exists"));
  7631.           }
  7632.         handle_ok:
  7633.         # handle und append_flag sind jetzt fertig.
  7634.         # Stream erzeugen:
  7635.         return make_file_stream(handle,direction,type,eltype_size,append_flag);
  7636.     } }
  7637.  
  7638. LISPFUN(open,1,0,norest,key,4,\
  7639.         (kw(direction),kw(element_type),kw(if_exists),kw(if_does_not_exist)) )
  7640. # (OPEN filename :direction :element-type :if-exists :if-does-not-exist),
  7641. # CLTL S. 418
  7642.   { var reg2 object filename = STACK_4; # filename
  7643.     if (streamp(filename))
  7644.       { # muß File-Stream sein:
  7645.         filename = as_file_stream(filename);
  7646.         # Streamtyp File-Stream -> Truename verwenden:
  7647.         filename = TheStream(filename)->strm_file_truename;
  7648.       }
  7649.       else
  7650.       { filename = coerce_pathname(filename); } # zu einem Pathname machen
  7651.     # filename ist jetzt ein Pathname.
  7652.    {var reg3 uintB direction;
  7653.     var reg4 uintB if_exists;
  7654.     var reg5 uintB if_not_exists;
  7655.     var reg6 uintB type;
  7656.     var reg7 object eltype_size = NIL;
  7657.     # :direction überprüfen und in direction übersetzen:
  7658.     { var reg1 object arg = STACK_3;
  7659.       if (eq(arg,unbound) || eq(arg,S(Kinput))) { direction = 1; }
  7660.       elif (eq(arg,S(Kinput_immutable))) { direction = 3; }
  7661.       elif (eq(arg,S(Koutput))) { direction = 4; }
  7662.       elif (eq(arg,S(Kio))) { direction = 5; }
  7663.       elif (eq(arg,S(Kprobe))) { direction = 0; }
  7664.       else
  7665.       { pushSTACK(arg); # Wert für Slot DATUM von TYPE-ERROR
  7666.         pushSTACK(O(type_direction)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  7667.         pushSTACK(arg); pushSTACK(S(open));
  7668.         //: DEUTSCH "~: Als :DIRECTION-Argument ist ~ unzulässig."
  7669.         //: ENGLISH "~: illegal :DIRECTION argument ~"
  7670.         //: FRANCAIS "~ : ~ n'est pas permis comme argument pour :DIRECTION."
  7671.         fehler(type_error, GETTEXT("~: illegal :DIRECTION argument ~"));
  7672.     } }
  7673.     # :element-type überprüfen und in type und eltype_size übersetzen:
  7674.     { var reg1 object arg = STACK_2;
  7675.       if (eq(arg,unbound) || eq(arg,S(string_char)) || eq(arg,S(Kdefault))) # STRING-CHAR, :DEFAULT
  7676.         { type = strmtype_sch_file; }
  7677.       elif (eq(arg,S(character))) # CHARACTER
  7678.         { type = strmtype_ch_file; }
  7679.       elif (eq(arg,S(bit))) # BIT
  7680.         { type = strmtype_iu_file; eltype_size = Fixnum_1; }
  7681.       elif (eq(arg,S(unsigned_byte))) # UNSIGNED-BYTE
  7682.         { type = strmtype_iu_file; eltype_size = fixnum(8); }
  7683.       elif (eq(arg,S(signed_byte))) # SIGNED-BYTE
  7684.         { type = strmtype_is_file; eltype_size = fixnum(8); }
  7685.       elif (consp(arg) && mconsp(Cdr(arg)) && nullp(Cdr(Cdr(arg)))) # zweielementige Liste
  7686.         { var reg2 object h = Car(arg);
  7687.           if (eq(h,S(mod))) # (MOD n)
  7688.             { type = strmtype_iu_file;
  7689.               h = Car(Cdr(arg)); # n
  7690.               # muß ein Integer >0 sein:
  7691.               if (!(integerp(h) && positivep(h) && !eq(h,Fixnum_0)))
  7692.                 goto bad_eltype;
  7693.               # eltype_size := (integer-length (1- n)) bilden:
  7694.               pushSTACK(filename); # filename retten
  7695.               pushSTACK(h); funcall(L(einsminus),1); # (1- n)
  7696.               pushSTACK(value1); funcall(L(integer_length),1); # (integer-length (1- n))
  7697.               eltype_size = value1;
  7698.               filename = popSTACK(); # filename zurück
  7699.             }
  7700.           elif (eq(h,S(unsigned_byte))) # (UNSIGNED-BYTE n)
  7701.             { type = strmtype_iu_file;
  7702.               eltype_size = Car(Cdr(arg));
  7703.             }
  7704.           elif (eq(h,S(signed_byte))) # (SIGNED-BYTE n)
  7705.             { type = strmtype_is_file;
  7706.               eltype_size = Car(Cdr(arg));
  7707.             }
  7708.           else goto bad_eltype;
  7709.           # eltype_size überprüfen:
  7710.           if (!(posfixnump(eltype_size) && !eq(eltype_size,Fixnum_0)
  7711.                 && ((oint_data_len < log2_intDsize+intCsize) # (Bei oint_data_len <= log2(intDsize)+intCsize-1
  7712.                     # ist stets eltype_size < 2^oint_data_len < intDsize*(2^intCsize-1).)
  7713.                     || (as_oint(eltype_size) < as_oint(fixnum(intDsize*(uintL)(bitm(intCsize)-1))))
  7714.              ) )   )
  7715.             goto bad_eltype;
  7716.         }
  7717.       else
  7718.         { bad_eltype:
  7719.           pushSTACK(STACK_2); pushSTACK(S(open));
  7720.           # type_error ?? 
  7721.           //: DEUTSCH "~: Als :ELEMENT-TYPE-Argument ist ~ unzulässig."
  7722.           //: ENGLISH "~: illegal :ELEMENT-TYPE argument ~"
  7723.           //: FRANCAIS "~ : ~ n'est pas permis comme argument pour :ELEMENT-TYPE."
  7724.           fehler(error,GETTEXT("~: illegal :ELEMENT-TYPE argument ~"));
  7725.     }   }
  7726.     # :if-exists überprüfen und in if_exists übersetzen:
  7727.     { var reg1 object arg = STACK_1;
  7728.       if (eq(arg,unbound)) { if_exists = 0; }
  7729.       elif (eq(arg,S(Kerror))) { if_exists = 1; }
  7730.       elif (eq(arg,NIL)) { if_exists = 2; }
  7731.       elif (eq(arg,S(Krename))) { if_exists = 3; }
  7732.       elif (eq(arg,S(Krename_and_delete))) { if_exists = 4; }
  7733.       elif (eq(arg,S(Knew_version)) || eq(arg,S(Ksupersede))) { if_exists = 5; }
  7734.       elif (eq(arg,S(Kappend))) { if_exists = 6; }
  7735.       elif (eq(arg,S(Koverwrite))) { if_exists = 7; }
  7736.       else
  7737.       { pushSTACK(arg); # Wert für Slot DATUM von TYPE-ERROR
  7738.         pushSTACK(O(type_if_exists)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  7739.         pushSTACK(arg); pushSTACK(S(open));
  7740.         //: DEUTSCH "~: Als :IF-EXISTS-Argument ist ~ unzulässig."
  7741.         //: ENGLISH "~: illegal :IF-EXISTS argument ~"
  7742.         //: FRANCAIS "~ : ~ n'est pas permis comme argument pour :IF-EXISTS."
  7743.         fehler(type_error, GETTEXT("~: illegal :IF-EXISTS argument ~"));
  7744.     } }
  7745.     # :if-does-not-exist überprüfen und in if_not_exists übersetzen:
  7746.     { var reg1 object arg = STACK_0;
  7747.       if (eq(arg,unbound)) { if_not_exists = 0; }
  7748.       elif (eq(arg,S(Kerror))) { if_not_exists = 1; }
  7749.       elif (eq(arg,NIL)) { if_not_exists = 2; }
  7750.       elif (eq(arg,S(Kcreate))) { if_not_exists = 3; }
  7751.       else
  7752.       { pushSTACK(arg); # Wert für Slot DATUM von TYPE-ERROR
  7753.         pushSTACK(O(type_if_does_not_exist)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  7754.         pushSTACK(arg); pushSTACK(S(open));
  7755.         //: DEUTSCH "~: Als :IF-DOES-NOT-EXIST-Argument ist ~ unzulässig."
  7756.         //: ENGLISH "~: illegal :IF-DOES-NOT-EXIST argument ~"
  7757.         //: FRANCAIS "~ : ~ n'est pas permis comme argument pour :IF-DOES-NOT-EXIST."
  7758.         fehler(type_error, GETTEXT("~: illegal :IF-DOES-NOT-EXIST argument ~"));
  7759.     } }
  7760.     # File öffnen:
  7761.     skipSTACK(5);
  7762.     value1 = open_file(filename,direction,if_exists,if_not_exists,type,eltype_size);
  7763.     mv_count=1;
  7764.   }}
  7765.  
  7766. # UP: Liefert eine Liste aller matchenden Pathnames.
  7767. # directory_search(pathname)
  7768. # > pathname: Pathname mit Device /= :WILD
  7769. #if defined(UNIX) || defined(WIN32_UNIX)
  7770. # > STACK_1: Circle-Flag
  7771. #endif
  7772. # > STACK_0: Full-Flag
  7773. # < ergebnis:
  7774. #     Falls name=NIL und type=NIL:     Liste aller matchenden Directories,
  7775. #     sonst (name=NIL -> name=:WILD):  Liste aller matchenden Dateien.
  7776. #     Jeweils als absoluter Pathname ohne Wildcards,
  7777. #     bzw. bei Dateien und Full-Flag /=NIL als Liste
  7778. #          (Pathname Write-Date Length)
  7779. #          mit  Pathname ohne :WILD/:WILD-INFERIORS-Komponenten,
  7780. #               Write-Date = Datum der Dateierstellung (ss mm hh dd mm yy),
  7781. #                 als Decoded-Time passend für ENCODE-UNIVERSAL-TIME,
  7782. #               Length = Länge der Datei (in Bytes).
  7783. # kann GC auslösen
  7784.   local object directory_search (object pathname);
  7785.   # Methode: Breadth-first-search, damit nur eine Suchoperation gleichzeitig
  7786.   # läuft.
  7787.   #
  7788.   #ifdef PATHNAME_EXT83
  7789.   #
  7790.   #ifdef WATCOM
  7791.     # Die findfirst/findnext-Routinen sollen gefälligst errno setzen:
  7792.     local int findfirst (const char * path, struct ffblk * buf, unsigned int attr);
  7793.     local int findnext (struct ffblk * buf);
  7794.     local int findfirst(path,buf,attr)
  7795.       var reg2 const char * path;
  7796.       var reg3 struct ffblk * buf;
  7797.       var reg4 unsigned int attr;
  7798.       { var reg1 unsigned int result = _dos_findfirst(path,attr,buf);
  7799.         if (result==0)
  7800.           { return 0; } # kein Error
  7801.           else
  7802.           { errno = result; # = _doserrno;
  7803.             return -1; # Error
  7804.       }   }
  7805.     local int findnext(buf)
  7806.       var reg2 struct ffblk * buf;
  7807.       { var reg1 unsigned int result = _dos_findnext(buf);
  7808.         if (result==0)
  7809.           { return 0; } # kein Error
  7810.           else
  7811.           { errno = result; # = _doserrno;
  7812.             return -1; # Error
  7813.       }   }
  7814.   #endif
  7815.   #
  7816.   # UP: Extrahiert Name und Typ aus dem DTA-Buffer.
  7817.   # Es wird angenommen, daß Name und Typ aus zulässigen Großbuchstaben
  7818.   # bestehen und eine Länge <= 8 bzw. 3 haben.
  7819.   # > asciz: Adresse des ASCIZ-Strings im DTA-Buffer
  7820.   # > def: Default-Typ
  7821.   # < -(STACK): Typ
  7822.   # < -(STACK): Name
  7823.   # Erniedrigt STACK um 2.
  7824.   # kann GC auslösen
  7825.     local void extract (const uintB* asciz, object def);
  7826.     local void extract(asciz,def)
  7827.       var reg3 const uintB* asciz;
  7828.       var reg4 object def;
  7829.       { pushSTACK(def); # Default-Typ in den Stack
  7830.        {# in Name.Typ aufspalten:
  7831.         var reg1 const uintB* ptr = asciz;
  7832.         var reg2 uintL count = 0;
  7833.         loop
  7834.           { var reg3 uintB ch = *ptr; # nächstes Zeichen
  7835.             if ((ch == 0) || (ch == '.')) # bei Nullbyte oder '.'
  7836.               break; # ist der Name zu Ende
  7837.             ptr++; count++; # weiterrücken
  7838.           }
  7839.         pushSTACK(make_string(asciz,count)); # String für Name erzeugen
  7840.         if (*ptr++ == 0) # mit Nullbyte beendet ?
  7841.           ; # ja -> Typ bleibt Default
  7842.           else
  7843.           { asciz = ptr; count = 0;
  7844.             until (*ptr++ == 0) { count++; } # bei Nullbyte ist der Typ zu Ende
  7845.             STACK_1 = make_string(asciz,count); # String für Typ erzeugen
  7846.           }
  7847.       }}
  7848.   #
  7849.   # UP: Sucht Subdirectories eines gegebenen Pathname.
  7850.   # subdirs(pathstring)
  7851.   # STACK_0 = Pathname, dessen Subdirectories zu suchen sind
  7852.   # STACK_1 = Liste, auf die die Pathnames der matchenden Subdirectories
  7853.   #           gepusht werden
  7854.   # > pathstring: Suchpfad als fertiger ASCIZ-String
  7855.   # verändert STACK_1, kann GC auslösen
  7856.     local void subdirs (object pathstring);
  7857.     local void subdirs(pathstring)
  7858.       var reg3 object pathstring;
  7859.       {
  7860.        #if defined(MSDOS) && !defined(WIN32_DOS)
  7861.         # Dateisuche gemäß DOS-Konvention:
  7862.         var struct ffblk DTA_buffer;
  7863.         set_break_sem_4(); # wegen DTA-Buffer gegen Unterbrechungen sperren
  7864.         # Suchanfang, suche nach Ordnern und normalen Dateien:
  7865.         begin_system_call();
  7866.         if (findfirst(TheAsciz(pathstring),&DTA_buffer,FA_DIREC|FA_ARCH|FA_RDONLY) <0)
  7867.           { if (!((errno==ENOENT)
  7868.                || (errno==ENOMORE)
  7869.                ) ) { OS_error(); } }
  7870.           else # Keine Datei gefunden -> Schleife nicht durchlaufen
  7871.           loop
  7872.             { # Stackaufbau: new-pathname-list, pathname.
  7873.               end_system_call();
  7874.               # gefundene Datei untersuchen:
  7875.               if (DTA_buffer.ff_attrib & FA_DIREC) # sollte ein Unterdirectory sein
  7876.                 if (!(DTA_buffer.ff_name[0] == '.')) # sollte nicht mit '.' anfangen
  7877.                   # (sonst ist es wohl '.' oder '..', wird übergangen)
  7878.                   { # in Name.Typ aufspalten, Default-Typ "" :
  7879.                     extract(&DTA_buffer.ff_name[0],O(leer_string));
  7880.                    {var reg1 object new_cons = allocate_cons();
  7881.                     Car(new_cons) = popSTACK(); Cdr(new_cons) = popSTACK();
  7882.                     # new_cons = (name . type)
  7883.                     pushSTACK(new_cons);
  7884.                     new_cons = allocate_cons();
  7885.                     Car(new_cons) = popSTACK();
  7886.                     # in ein-elementiger Liste new_cons = list1 = ((name . type))
  7887.                     pushSTACK(new_cons);
  7888.                    }# Stackaufbau: new-pathname-list, pathname, list1.
  7889.                     # letzten Pathname kopieren:
  7890.                    {var reg1 object temp = copy_pathname(STACK_1);
  7891.                     pushSTACK(temp);
  7892.                     # und darin Directory um list1 = ((name . type)) verlängern:
  7893.                     # (append pathname-dir list1) = (nreconc (reverse pathname-dir) list1)
  7894.                     temp = reverse(ThePathname(temp)->pathname_directory);
  7895.                     temp = nreconc(temp,STACK_1);
  7896.                     ThePathname(STACK_0)->pathname_directory = temp;
  7897.                    }# Stackaufbau: new-pathname-list, pathname, list1, newpathname.
  7898.                     # newpathname auf die Liste new-pathname-list pushen:
  7899.                    {var reg1 object new_cons = allocate_cons();
  7900.                     Car(new_cons) = popSTACK(); skipSTACK(1);
  7901.                     Cdr(new_cons) = STACK_1; STACK_1 = new_cons;
  7902.                   }}
  7903.               # nächstes File:
  7904.               begin_system_call();
  7905.               if (findnext(&DTA_buffer) <0)
  7906.                 { if (!((errno==ENOENT) 
  7907.                      || (errno==ENOMORE)
  7908.                      #ifdef EACESS  # DJGPP2
  7909.                      || (errno==EACESS)
  7910.                      #endif
  7911.                      ) ) { OS_error(); }
  7912.                   break; # Keine weitere Datei -> Schleifenende
  7913.                 }
  7914.             }
  7915.         end_system_call();
  7916.         clr_break_sem_4();
  7917.        #elif defined(WIN32_DOS)
  7918.         # Dateisuche gemäß DOS-Konvention:
  7919.         var WIN32_FIND_DATA ffd;
  7920.         var HANDLE hFindFile;
  7921.         set_break_sem_4(); # wegen DTA-Buffer gegen Unterbrechungen sperren
  7922.         # Suchanfang, suche nach Ordnern und normalen Dateien:
  7923.         begin_system_call();
  7924.         if ((hFindFile = FindFirstFile(TheAsciz(pathstring),&ffd)) == INVALID_HANDLE_VALUE) 
  7925.             { OS_error(); }
  7926.           else # Keine Datei gefunden -> Schleife nicht durchlaufen
  7927.           loop
  7928.             { # Stackaufbau: new-pathname-list, pathname.
  7929.               end_system_call();
  7930.               # gefundene Datei untersuchen:
  7931.               if (ffd.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) # sollte ein Unterdirectory sein
  7932.                 if (!(ffd.cFileName[0] == '.')) # sollte nicht mit '.' anfangen
  7933.                   # (sonst ist es wohl '.' oder '..', wird übergangen)
  7934.                   { # in Name.Typ aufspalten, Default-Typ "" :
  7935.                     extract(&ffd.cFileName[0],O(leer_string));
  7936.                    {var reg1 object new_cons = allocate_cons();
  7937.                     Car(new_cons) = popSTACK(); Cdr(new_cons) = popSTACK();
  7938.                     # new_cons = (name . type)
  7939.                     pushSTACK(new_cons);
  7940.                     new_cons = allocate_cons();
  7941.                     Car(new_cons) = popSTACK();
  7942.                     # in ein-elementiger Liste new_cons = list1 = ((name . type))
  7943.                     pushSTACK(new_cons);
  7944.                    }# Stackaufbau: new-pathname-list, pathname, list1.
  7945.                     # letzten Pathname kopieren:
  7946.                    {var reg1 object temp = copy_pathname(STACK_1);
  7947.                     pushSTACK(temp);
  7948.                     # und darin Directory um list1 = ((name . type)) verlängern:
  7949.                     # (append pathname-dir list1) = (nreconc (reverse pathname-dir) list1)
  7950.                     temp = reverse(ThePathname(temp)->pathname_directory);
  7951.                     temp = nreconc(temp,STACK_1);
  7952.                     ThePathname(STACK_0)->pathname_directory = temp;
  7953.                    }# Stackaufbau: new-pathname-list, pathname, list1, newpathname.
  7954.                     # newpathname auf die Liste new-pathname-list pushen:
  7955.                    {var reg1 object new_cons = allocate_cons();
  7956.                     Car(new_cons) = popSTACK(); skipSTACK(1);
  7957.                     Cdr(new_cons) = STACK_1; STACK_1 = new_cons;
  7958.                   }}
  7959.               # nächstes File:
  7960.               begin_system_call();
  7961.               if (FindNextFile (hFindFile, &ffd) == FALSE)
  7962.                 { if (GetLastError() != ERROR_NO_MORE_FILES) { OS_error(); }
  7963.                   break; # Keine weitere Datei -> Schleifenende
  7964.                 }
  7965.             }
  7966.         end_system_call();
  7967.         clr_break_sem_4();
  7968.        #endif
  7969.       }
  7970.   #
  7971.   # UP: Sucht alle Subdirectories (beliebiger Tiefe) eines gegebenen Pathname.
  7972.   # allsubdirs(pathnamelist)
  7973.   # > pathnamelist: Liste, dessen CAR der gegebene Pathname ist.
  7974.   # Die Pathnames aller echten Subdirectories (beliebiger Tiefe) werden als
  7975.   # Liste destruktiv zwischen pathnamelist und (cdr pathnamelist) gehängt.
  7976.   # < ergebnis: das ursprüngliche (cdr pathnamelist)
  7977.   # kann GC auslösen
  7978.     local object allsubdirs (object pathnamelist);
  7979.     local object allsubdirs(pathnamelist)
  7980.       var reg1 object pathnamelist;
  7981.       { pushSTACK(pathnamelist);
  7982.         pushSTACK(NIL); # new-pathname-list := NIL
  7983.         {var reg2 object pathname = Car(pathnamelist);
  7984.          pushSTACK(pathname);
  7985.          # Stackaufbau: pathnamelist, new-pathname-list, pathname.
  7986.          {var reg3 uintC stringcount =
  7987.             directory_namestring_parts(pathname); # Directory-Namestring-Teile,
  7988.           pushSTACK(O(wild_wild_string)); # "*.*"
  7989.           pushSTACK(O(null_string)); # und Nullbyte
  7990.           {var reg4 object pathstring = string_concat(stringcount+1+1); # zusammenhängen
  7991.            subdirs(pathstring); # alle subdirs auf new-pathname-list pushen
  7992.         }}}
  7993.         skipSTACK(1); # pathname vergessen
  7994.         { var reg2 object new_pathname_list = popSTACK();
  7995.           pathnamelist = popSTACK();
  7996.           # Stackaufbau: (leer).
  7997.           # Mit  (setf (cdr pathnamelist)
  7998.           #            (nreconc new-pathname-list (cdr pathnamelist))
  7999.           #      )
  8000.           # die new-pathname-list umdrehen und gleichzeitig einhängen:
  8001.           new_pathname_list = nreconc(new_pathname_list,Cdr(pathnamelist));
  8002.           pushSTACK(Cdr(pathnamelist)); Cdr(pathnamelist) = new_pathname_list;
  8003.           pathnamelist = new_pathname_list;
  8004.         }
  8005.         # Stackaufbau: ursprüngliches (cdr pathnamelist).
  8006.         # Liste pathnamelist durchlaufen, bis bei STACK_0 angelangt,
  8007.         # und rekursiv alle Subdirectories bestimmen und einhängen:
  8008.         until (eq(pathnamelist,STACK_0))
  8009.           { pathnamelist = allsubdirs(pathnamelist); }
  8010.         skipSTACK(1);
  8011.         return pathnamelist;
  8012.       }
  8013.   #
  8014.   local object directory_search(pathname)
  8015.     var reg4 object pathname;
  8016.     { pathname = use_default_dir(pathname); # Default-Directory einfügen
  8017.       # pathname ist jetzt ein Pathname, bei dem Device ein überprüfter
  8018.       # String ist und Directory [die Seriennummer, aber] kein
  8019.       # :RELATIVE, :CURRENT, :PARENT enthält.
  8020.       pushSTACK(pathname);
  8021.       pushSTACK(ThePathname(pathname)->pathname_directory); # subdir-list
  8022.       # pathname kopieren:
  8023.       pushSTACK(copy_pathname(pathname));
  8024.       # und dessen Directory auf ([Seriennummer] :ABSOLUTE) verkürzen:
  8025.       {var reg1 object new_cons = allocate_cons(); # neues Cons mit CDR=NIL
  8026.        Car(new_cons) = S(Kabsolute); # :ABSOLUTE als CAR
  8027.        ThePathname(STACK_0)->pathname_directory = new_cons;
  8028.       }
  8029.       # und in einelementige Liste packen:
  8030.       {var reg1 object new_cons = allocate_cons();
  8031.        Car(new_cons) = STACK_0;
  8032.        STACK_0 = new_cons;
  8033.       }
  8034.       while
  8035.         # Stackaufbau: pathname, subdir-list, pathname-list.
  8036.         # Dabei enthalten die Pathnames aus pathname-list das Directory
  8037.         # nur so tief, daß es danach mit (cdr subdir-list) weitergeht.
  8038.         # Nächste subdir-Ebene abarbeiten:
  8039.         (consp (STACK_1 = Cdr(STACK_1))) # subdir-list verkürzen
  8040.         { # pathname-list durchgehen und dabei neue Liste aufbauen:
  8041.           pushSTACK(STACK_0); pushSTACK(NIL);
  8042.           loop
  8043.             { # Stackaufbau: ..., pathname-list-rest, new-pathname-list.
  8044.               var reg2 object pathname_list_rest = STACK_1;
  8045.               if (atomp(pathname_list_rest)) break;
  8046.               STACK_1 = Cdr(pathname_list_rest);
  8047.              {var reg5 object next_pathname = Car(pathname_list_rest); # nächster Pathname
  8048.               var reg3 object subdir_list = STACK_(1+2);
  8049.               pushSTACK(next_pathname); # in den Stack
  8050.               if (!eq(Car(subdir_list),S(Kwild_inferiors))) # nächstes subdir = :WILD-INFERIORS ?
  8051.                 { # normales subdir:
  8052.                   var reg1 uintC stringcount =
  8053.                     directory_namestring_parts(next_pathname); # Directory-Namestring-Teile (keine GC!)
  8054.                   stringcount +=
  8055.                     subdir_namestring_parts(subdir_list); # und Strings zum nächsten subdir
  8056.                   pushSTACK(O(null_string)); stringcount += 1; # und Nullbyte
  8057.                  {var reg6 object pathstring = string_concat(stringcount); # zusammenhängen
  8058.                   subdirs(pathstring); # alle subdirs auf new-pathname-list pushen
  8059.                   skipSTACK(1); # next-pathname vergessen
  8060.                 }}
  8061.                 else
  8062.                 { # subdir = :WILD-INFERIORS -> alle Subdirs bestimmen:
  8063.                   {var reg1 object list1 = allocate_cons();
  8064.                    Car(list1) = STACK_0;
  8065.                    STACK_0 = list1; # einelementige Liste (next-pathname)
  8066.                    allsubdirs(list1); # alle Subdirectories bestimmen
  8067.                   }
  8068.                   # Liste aller Subdirectories vor new-pathname-list
  8069.                   # in umgekehrter Reihenfolge davorhängen:
  8070.                   # (nreconc subdirlist new-pathname-list)
  8071.                   {var reg1 object newsubdirlist = popSTACK();
  8072.                    STACK_0 = nreconc(newsubdirlist,STACK_0);
  8073.                 } }
  8074.               # nächsten Pathname aus pathname-list-rest nehmen
  8075.             }}
  8076.          {var reg1 object new_pathname_list = popSTACK(); skipSTACK(1);
  8077.           # umdrehen und als nächste pathname-list verwenden:
  8078.           STACK_0 = nreverse(new_pathname_list);
  8079.         }}
  8080.       # Stackaufbau: pathname, nix, pathname-list.
  8081.       pathname = STACK_2;
  8082.       {var reg2 object name = ThePathname(pathname)->pathname_name;
  8083.        var reg3 object type = ThePathname(pathname)->pathname_type;
  8084.        if (nullp(name)) # Name=NIL ?
  8085.          { if (nullp(type)) # auch Typ=NIL ?
  8086.              { var reg1 object new_pathname_list = popSTACK(); # ja ->
  8087.                skipSTACK(2); return new_pathname_list; # schon fertig
  8088.              }
  8089.              else
  8090.              # nein -> verwende :WILD (statt NIL) als Name
  8091.              { name = S(Kwild); }
  8092.          }
  8093.        # Alle Files name.type in den gegebenen Subdirectories suchen:
  8094.        { var reg1 uintC stringcount =
  8095.            nametype_namestring_parts(name,type,ThePathname(pathname)->pathname_version); # Teilstrings zu Name und Typ
  8096.          pushSTACK(O(null_string)); stringcount++; # und Nullbyte
  8097.         {var reg2 object name_type_asciz = string_concat(stringcount);
  8098.          STACK_2 = name_type_asciz;
  8099.       }}}
  8100.       STACK_1 = STACK_0; # pathname-list
  8101.       STACK_0 = NIL; # new-pathname-list := NIL
  8102.       # Stackaufbau: name-type-asciz, pathname-list, new-pathname-list.
  8103.       loop
  8104.         { var reg5 object pathname_list_rest = STACK_1;
  8105.           if (atomp(pathname_list_rest)) break;
  8106.           STACK_1 = Cdr(pathname_list_rest);
  8107.          {var reg8 object next_pathname = Car(pathname_list_rest); # nächster Pathname
  8108.           var reg7 object name_type_asciz = STACK_2;
  8109.           pushSTACK(next_pathname); # in den Stack
  8110.           {var reg3 uintC stringcount =
  8111.              directory_namestring_parts(next_pathname); # Directory-Namestring-Teile (keine GC!)
  8112.            pushSTACK(name_type_asciz); stringcount += 1; # und name-type-asciz
  8113.            {var reg6 object pathstring = string_concat(stringcount); # zusammenhängen
  8114.             #if defined(MSDOS) && !defined(WIN32_DOS)
  8115.              # Dateisuche gemäß DOS-Konvention:
  8116.              var struct ffblk DTA_buffer;
  8117.              set_break_sem_4(); # wegen DTA-Buffer gegen Unterbrechungen sperren
  8118.              # Suchanfang, suche nur nach normalen Dateien:
  8119.              begin_system_call();
  8120.              if (findfirst(TheAsciz(pathstring),&DTA_buffer,FA_ARCH|FA_RDONLY) <0)
  8121.                { if (!((errno==ENOENT) 
  8122.                     || (errno==ENOMORE)
  8123.                     ) ) { OS_error(); } }
  8124.                else # Keine Datei gefunden -> Schleife nicht durchlaufen
  8125.                loop
  8126.                  { # Stackaufbau: ..., next-pathname.
  8127.                    end_system_call();
  8128.                    # gefundene Datei untersuchen:
  8129.                    { # in Name.Typ aufspalten, Default-Typ NIL :
  8130.                      extract(&DTA_buffer.ff_name[0],NIL);
  8131.                     {# letzten Pathname kopieren und Name und Typ eintragen:
  8132.                      var reg1 object new = copy_pathname(STACK_2);
  8133.                      ThePathname(new)->pathname_name = popSTACK();
  8134.                      ThePathname(new)->pathname_type = popSTACK();
  8135.                      # Full-Flag abtesten und evtl. mehr Information besorgen:
  8136.                      if (!nullp(STACK_(0+3+1)))
  8137.                        { pushSTACK(new); # newpathname als 1. Listenelement
  8138.                          pushSTACK(new); # newpathname als 2. Listenelement
  8139.                          { # Uhrzeit und Datum von DOS-Format in Decoded-Time umwandeln:
  8140.                            var decoded_time timepoint;
  8141.                            convert_timedate((uintW)DTA_buffer.ff_ftime,(uintW)DTA_buffer.ff_fdate,
  8142.                                         &timepoint);
  8143.                            pushSTACK(timepoint.Sekunden);
  8144.                            pushSTACK(timepoint.Minuten);
  8145.                            pushSTACK(timepoint.Stunden);
  8146.                            pushSTACK(timepoint.Tag);
  8147.                            pushSTACK(timepoint.Monat);
  8148.                            pushSTACK(timepoint.Jahr);
  8149.                            new = listof(6); # 6-elementige Liste bauen
  8150.                          }
  8151.                          pushSTACK(new); # als 3. Listenelement
  8152.                          pushSTACK(UL_to_I(*(uintL*)(&DTA_buffer.ff_fsize))); # Länge als 4. Listenelement
  8153.                          new = listof(4); # 4-elementige Liste bauen
  8154.                        }
  8155.                      # new auf die Liste new-pathname-list pushen:
  8156.                       pushSTACK(new);
  8157.                      {var reg1 object new_cons = allocate_cons();
  8158.                       Car(new_cons) = popSTACK();
  8159.                       Cdr(new_cons) = STACK_(0+1);
  8160.                       STACK_(0+1) = new_cons;
  8161.                    }}}
  8162.                    # nächstes File:
  8163.                    begin_system_call();
  8164.                    if (findnext(&DTA_buffer) <0)
  8165.                      { if (!((errno==ENOENT) 
  8166.                           || (errno==ENOMORE)
  8167.                           ) ) { OS_error(); }
  8168.                        break; # Keine weitere Datei -> Schleifenende
  8169.                      }
  8170.                  }
  8171.              end_system_call();
  8172.              clr_break_sem_4();
  8173.             #elif defined(WIN32_DOS)
  8174.              # Dateisuche gemäß DOS-Konvention:
  8175.              var WIN32_FIND_DATA ffd;
  8176.              var HANDLE hFindFile;
  8177.              set_break_sem_4(); # wegen DTA-Buffer gegen Unterbrechungen sperren
  8178.              # Suchanfang, suche nur nach normalen Dateien:
  8179.              begin_system_call();
  8180.              if ((hFindFile=FindFirstFile(TheAsciz(pathstring),&ffd)) == INVALID_HANDLE_VALUE)
  8181.                { OS_error(); }
  8182.                else # Keine Datei gefunden -> Schleife nicht durchlaufen
  8183.                loop
  8184.                  { # Stackaufbau: ..., next-pathname.
  8185.                    end_system_call();
  8186.                    # gefundene Datei untersuchen:
  8187.                    { # in Name.Typ aufspalten, Default-Typ NIL :
  8188.                      extract(&ffd.cFileName[0],NIL);
  8189.                     {# letzten Pathname kopieren und Name und Typ eintragen:
  8190.                      var reg1 object new = copy_pathname(STACK_2);
  8191.                      ThePathname(new)->pathname_name = popSTACK();
  8192.                      ThePathname(new)->pathname_type = popSTACK();
  8193.                      # Full-Flag abtesten und evtl. mehr Information besorgen:
  8194.                      if (!nullp(STACK_(0+3+1)))
  8195.                        { pushSTACK(new); # newpathname als 1. Listenelement
  8196.                          pushSTACK(new); # newpathname als 2. Listenelement
  8197.                          { # Uhrzeit und Datum von DOS-Format in Decoded-Time umwandeln:
  8198.                            var decoded_time timepoint;
  8199.                            var WORD date;
  8200.                            var WORD time;
  8201.                            FileTimeToDosDateTime(&ffd.ftLastWriteTime,&date,&time);
  8202.                            convert_timedate((uintW)time,(uintW)date,&timepoint);
  8203.                            pushSTACK(timepoint.Sekunden);
  8204.                            pushSTACK(timepoint.Minuten);
  8205.                            pushSTACK(timepoint.Stunden);
  8206.                            pushSTACK(timepoint.Tag);
  8207.                            pushSTACK(timepoint.Monat);
  8208.                            pushSTACK(timepoint.Jahr);
  8209.                            new = listof(6); # 6-elementige Liste bauen
  8210.                          }
  8211.                          pushSTACK(new); # als 3. Listenelement
  8212.                          pushSTACK(UL_to_I(*(uintL*)(&ffd.nFileSizeLow))); # Länge als 4. Listenelement
  8213.                          new = listof(4); # 4-elementige Liste bauen
  8214.                        }
  8215.                      # new auf die Liste new-pathname-list pushen:
  8216.                       pushSTACK(new);
  8217.                      {var reg1 object new_cons = allocate_cons();
  8218.                       Car(new_cons) = popSTACK();
  8219.                       Cdr(new_cons) = STACK_(0+1);
  8220.                       STACK_(0+1) = new_cons;
  8221.                    }}}
  8222.                    # nächstes File:
  8223.                    begin_system_call();
  8224.                    if (FindNextFile(hFindFile,&ffd) == FALSE)
  8225.                      { if (GetLastError() != ERROR_NO_MORE_FILES) 
  8226.                          { OS_error(); }
  8227.                        break; # Keine weitere Datei -> Schleifenende
  8228.                      }
  8229.                  }
  8230.              end_system_call();
  8231.              clr_break_sem_4();
  8232.             #endif
  8233.           }}
  8234.           skipSTACK(1); # next-pathname vergessen
  8235.         }}
  8236.       {# new-pathname-list wieder umdrehen:
  8237.        var reg1 object new_pathname_list = nreverse(popSTACK());
  8238.        skipSTACK(2); return new_pathname_list;
  8239.     } }
  8240.   #
  8241.   #endif # PATHNAME_EXT83
  8242.   #
  8243.   #if defined(PATHNAME_NOEXT) || defined(PATHNAME_RISCOS)
  8244.   #
  8245.   # UP: Erweitert das Directory eines Pathname um eine Komponente.
  8246.   # > STACK_1: ein Pathname
  8247.   # > STACK_0: neue Subdir-Komponente, ein Simple-String
  8248.   # < ergebnis: neuer Pathname mit um subdir verlängertem Directory
  8249.   # Erhöht STACK um 2
  8250.   # kann GC auslösen
  8251.   local object pathname_add_subdir (void);
  8252.   local object pathname_add_subdir()
  8253.     { # Pathname kopieren und dessen Directory gemäß
  8254.       # (append x (list y)) = (nreverse (cons y (reverse x))) verlängern:
  8255.       var reg2 object pathname = copy_pathname(STACK_1);
  8256.       STACK_1 = pathname;
  8257.       pushSTACK(reverse(ThePathname(pathname)->pathname_directory));
  8258.      {var reg1 object new_cons = allocate_cons();
  8259.       Cdr(new_cons) = popSTACK();
  8260.       Car(new_cons) = popSTACK();
  8261.       new_cons = nreverse(new_cons);
  8262.       pathname = popSTACK();
  8263.       ThePathname(pathname)->pathname_directory = new_cons;
  8264.       return pathname;
  8265.     }}
  8266.   #
  8267.   #if defined(UNIX) || defined(AMIGAOS) || defined(RISCOS) || defined(WIN32_UNIX)
  8268.   # UP: Erweitert einen Pathname um die File-Information.
  8269.   # > STACK_1: absoluter Pathname
  8270.   # > STACK_0: absoluter Pathname, Links aufgelöst
  8271.   # > *filestatus: dessen stat-Info
  8272.   # < STACK_0: Liste (Pathname Truename Write-Date Length [Kommentar]) im :FULL-Format
  8273.   local void with_stat_info (void);
  8274.   local void with_stat_info()
  8275.     { var reg2 object new;
  8276.       #if defined(UNIX) || defined(RISCOS) || defined(WIN32_UNIX)
  8277.       var reg3 uintL size = filestatus->st_size;
  8278.       #endif
  8279.       #ifdef AMIGAOS
  8280.       var reg3 uintL size = filestatus->fib_Size;
  8281.       #endif
  8282.       # Pathname schon in STACK_1, als 1. Listenelement
  8283.       # Truename schon in STACK_0, als 2. Listenelement
  8284.       { var decoded_time timepoint; # Write-Date in decodierter Form
  8285.         #if defined(UNIX) || defined(RISCOS) || defined(WIN32_UNIX)
  8286.         convert_time(&filestatus->st_mtime,&timepoint);
  8287.         #endif
  8288.         #ifdef AMIGAOS
  8289.         convert_time(&filestatus->fib_Date,&timepoint);
  8290.         #endif
  8291.         pushSTACK(timepoint.Sekunden);
  8292.         pushSTACK(timepoint.Minuten);
  8293.         pushSTACK(timepoint.Stunden);
  8294.         pushSTACK(timepoint.Tag);
  8295.         pushSTACK(timepoint.Monat);
  8296.         pushSTACK(timepoint.Jahr);
  8297.         new = listof(6); # 6-elementige Liste bauen
  8298.       }
  8299.       pushSTACK(new); # als 3. Listenelement
  8300.       pushSTACK(UL_to_I(size)); # Länge als 4. Listenelement
  8301.       #if defined(UNIX) || defined(RISCOS) || defined(WIN32_UNIX)
  8302.       new = listof(4); # 4-elementige Liste bauen
  8303.       #endif
  8304.       #ifdef AMIGAOS
  8305.       pushSTACK(asciz_to_string(&filestatus->fib_Comment[0])); # Kommentar als 5. Listenelement
  8306.       new = listof(5); # 5-elementige Liste bauen
  8307.       #endif
  8308.       pushSTACK(Car(new)); # pathname wieder in den Stack
  8309.       pushSTACK(new); # Liste in den Stack
  8310.     }
  8311.   #endif
  8312.   #
  8313.   local object directory_search(pathname)
  8314.     var reg9 object pathname;
  8315.     {
  8316.       #ifdef PATHNAME_RISCOS
  8317.       # If we search for a file with type /= NIL, we have to interpret the last
  8318.       # subdir as the type.
  8319.       var boolean name_and_type = FALSE;
  8320.       #endif
  8321.       pathname = use_default_dir(pathname); # Default-Directory einfügen
  8322.       # pathname ist jetzt neu und ein absoluter Pathname.
  8323.       pushSTACK(NIL); # result-list := NIL
  8324.       pushSTACK(pathname);
  8325.       # Falls name=NIL und type/=NIL: Setze name := "*".
  8326.       if (nullp(ThePathname(pathname)->pathname_name)
  8327.           && !nullp(ThePathname(pathname)->pathname_type)
  8328.          )
  8329.         { ThePathname(pathname)->pathname_name = O(wild_string); }
  8330.       #ifdef PATHNAME_RISCOS
  8331.       # If the name and type are both set, then make the type part of
  8332.       # the directory specification and set the new type to NIL.
  8333.       if (!nullp(ThePathname(pathname)->pathname_name)
  8334.           && !nullp(ThePathname(pathname)->pathname_type)
  8335.          )
  8336.         { name_and_type = TRUE;
  8337.           pushSTACK(pathname); pushSTACK(ThePathname(pathname)->pathname_type);
  8338.           STACK_0 = pathname = pathname_add_subdir();
  8339.           ThePathname(pathname)->pathname_type = NIL;
  8340.         }
  8341.       #endif
  8342.       # Zum Matchen: Name und Typ zu einem String zusammenfassen:
  8343.       if (nullp(ThePathname(pathname)->pathname_name))
  8344.         { pushSTACK(NIL); } # name=NIL -> auch type=NIL -> keine Files suchen
  8345.         else
  8346.         {var reg1 uintC stringcount = file_namestring_parts(pathname);
  8347.          var reg1 object nametype_string = string_concat(stringcount);
  8348.          pathname = STACK_0;
  8349.          pushSTACK(nametype_string);
  8350.         }
  8351.       pushSTACK(ThePathname(pathname)->pathname_directory); # subdir-list
  8352.       #ifdef PATHNAME_RISCOS
  8353.       STACK_0 = Cdr(STACK_0); # Liste fängt mit (:ABSOLUTE :ROOT ...) an, verkürze sie
  8354.       #endif
  8355.       # pathname kopieren und dabei Name und Typ streichen und
  8356.       # Directory zu (:ABSOLUTE) bzw. (:ABSOLUTE :ROOT) verkürzen:
  8357.       pathname = copy_pathname(pathname);
  8358.       ThePathname(pathname)->pathname_name = NIL;
  8359.       ThePathname(pathname)->pathname_type = NIL;
  8360.       ThePathname(pathname)->pathname_directory = O(directory_absolute);
  8361.       pushSTACK(pathname);
  8362.       # und in einelementige Liste packen:
  8363.       {var reg1 object new_cons = allocate_cons();
  8364.        Car(new_cons) = STACK_0;
  8365.        STACK_0 = new_cons;
  8366.       }
  8367.      {var reg7 boolean recursively = # Flag, ob die nächste Operation auf
  8368.         FALSE;                       # alle Subdirectories anzuwenden ist.
  8369.       loop
  8370.         # Stackaufbau: result-list, pathname, name&type, subdir-list, pathname-list.
  8371.         # result-list = Liste der fertigen Pathnames/Listen, umgedreht.
  8372.         # name&type = NIL oder Simple-String, gegen den die Filenamen zu matchen sind.
  8373.         # pathname-list = Liste der noch abzuarbeitenden Directories.
  8374.         # Dabei enthalten die Pathnames aus pathname-list das Directory
  8375.         # nur so tief, daß es danach mit (cdr subdir-list) weitergeht.
  8376.         { # Nächste subdir-Ebene abarbeiten:
  8377.           STACK_1 = Cdr(STACK_1); # subdir-list verkürzen
  8378.          {var reg6 signean next_task; # Was mit den Dirs aus pathname-list zu tun ist:
  8379.             # 0: nichts, fertig
  8380.             # 1: nach einem File gegebenen Namens/Typs sehen
  8381.             # -1: nach einem Subdirectory gegebenen Namens sehen
  8382.             # 2: nach allen Files suchen, die gegebenen Namen/Typ matchen
  8383.             # -2: nach allen Subdirectories suchen, die gegebenen Namen matchen
  8384.           if (matomp(STACK_1)) # subdir-list zu Ende?
  8385.             { var reg1 object nametype = STACK_2;
  8386.               if (nullp(nametype)) # name=NIL und type=NIL -> keine Files suchen
  8387.                 { next_task = 0; }
  8388.               #ifndef MSDOS
  8389.               elif (!has_wildcards(nametype))
  8390.                    # === !(has_wildcards(name) || ((!nullp(type)) && has_wildcards(type)))
  8391.                 { next_task = 1; } # File suchen
  8392.               #endif
  8393.               else
  8394.                 { next_task = 2; } # Files mit Wildcards suchen
  8395.             }
  8396.             else
  8397.             { var reg1 object next_subdir = Car(STACK_1);
  8398.               if (eq(next_subdir,S(Kwild_inferiors))) # '...' ?
  8399.                 # wird erst beim nächsten Durchlauf behandelt
  8400.                 { recursively = TRUE; goto passed_subdir; }
  8401.               #ifndef MSDOS
  8402.               if (
  8403.                   #ifdef PATHNAME_AMIGAOS
  8404.                   eq(next_subdir,S(Kparent)) ||
  8405.                   #endif
  8406.                   #ifdef PATHNAME_RISCOS
  8407.                   !simple_string_p(next_subdir) ||
  8408.                   #endif
  8409.                   !has_wildcards(next_subdir)
  8410.                  )
  8411.                 { next_task = -1; } # Subdir suchen
  8412.                 else
  8413.               #endif
  8414.                 { next_task = -2; } # Subdirs mit Wildcards suchen
  8415.             }
  8416.           # pathname-list durchgehen und dabei neue Liste aufbauen:
  8417.           pushSTACK(NIL);
  8418.           #if defined(UNIX) || defined(WIN32_UNIX)
  8419.           if (!nullp(STACK_(1+5+1))) # ;CIRCLE-Flag abfragen
  8420.             { # Hash-Tabelle aller bisher abgesuchten Directories (jeweils
  8421.               # als Cons (dev . ino)) führen:
  8422.               pushSTACK(S(Ktest)); pushSTACK(S(equal));
  8423.               funcall(L(make_hash_table),2); # (MAKE-HASH-TABLE :TEST 'EQUAL)
  8424.               pushSTACK(value1);
  8425.             }
  8426.             else
  8427.             { pushSTACK(NIL); }
  8428.           #define H 1
  8429.           #else
  8430.           #define H 0
  8431.           #endif
  8432.           pushSTACK(STACK_(0+1+H));
  8433.           loop
  8434.             { # Stackaufbau: ..., new-pathname-list, [ht,] pathname-list-rest.
  8435.               var reg9 object pathname_list_rest = STACK_0;
  8436.               if (atomp(pathname_list_rest)) break;
  8437.               STACK_0 = Cdr(pathname_list_rest); # Liste verkürzen
  8438.               pushSTACK(NIL); # pathnames-to-insert := NIL
  8439.               # Stackaufbau: ..., new-pathname-list, [ht,] pathname-list-rest, pathnames-to-insert.
  8440.              {var reg9 object pathname = Car(pathname_list_rest); # nächstes Directory
  8441.               pushSTACK(pathname); # in den Stack
  8442.               # Versuche, die Task ein wenig abzukürzen:
  8443.               if (!recursively)
  8444.                 { switch (next_task)
  8445.                     { case 0: # Dieses pathname liefern
  8446.                         #if defined(UNIX) || defined(WIN32_UNIX)
  8447.                         assure_dir_exists(FALSE); # erst noch Links auflösen
  8448.                         #endif
  8449.                         # und STACK_0 vor result-list pushen:
  8450.                         {var reg1 object new_cons = allocate_cons();
  8451.                          Car(new_cons) = popSTACK();
  8452.                          Cdr(new_cons) = STACK_(4+(1+H+2));
  8453.                          STACK_(4+(1+H+2)) = new_cons;
  8454.                         }
  8455.                         goto next_pathname;
  8456.                       #ifndef MSDOS
  8457.                       case 1: # In diesem pathname nach einem File sehen
  8458.                         ThePathname(pathname)->pathname_name = # Name (/=NIL) einsetzen
  8459.                           ThePathname(STACK_(3+(1+H+2)+1))->pathname_name;
  8460.                         ThePathname(pathname)->pathname_type = # Typ einsetzen
  8461.                           ThePathname(STACK_(3+(1+H+2)+1))->pathname_type;
  8462.                         pushSTACK(pathname);
  8463.                         #ifdef PATHNAME_RISCOS
  8464.                         if (name_and_type && nullp(ThePathname(pathname)->pathname_type))
  8465.                           # Move the last subdir into the type slot of the pathname.
  8466.                           { # subdirs := (butlast subdirs) = (nreverse (cdr (reverse subdirs)))
  8467.                             var reg1 object subdirs = reverse(ThePathname(pathname)->pathname_directory);
  8468.                             pathname = STACK_0;
  8469.                             ThePathname(pathname)->pathname_type = Car(subdirs);
  8470.                             ThePathname(pathname)->pathname_directory = nreverse(Cdr(subdirs));
  8471.                           }
  8472.                         #endif
  8473.                         assure_dir_exists(FALSE); # Links auflösen, File suchen
  8474.                         if (file_exists(_EMA_)) # falls File existiert
  8475.                           { if (!nullp(STACK_(0+5+(1+H+2)+2))) # :FULL gewünscht?
  8476.                               { with_stat_info(); } # ja -> STACK_0 erweitern
  8477.                             # und STACK_0 vor result-list pushen:
  8478.                            {var reg1 object new_cons = allocate_cons();
  8479.                             Car(new_cons) = STACK_0;
  8480.                             Cdr(new_cons) = STACK_(4+(1+H+2)+2);
  8481.                             STACK_(4+(1+H+2)+2) = new_cons;
  8482.                           }}
  8483.                         skipSTACK(2);
  8484.                         goto next_pathname;
  8485.                       case -1: # In diesem pathname nach einem Subdirectory sehen
  8486.                         { var reg2 object namestring = assure_dir_exists(FALSE); # Links auflösen, Directory-Namestring
  8487.                           pushSTACK(namestring); # Directory-Namestring
  8488.                           {var reg1 object subdir = Car(STACK_(1+(1+H+2)+1+1)); # (car subdir-list)
  8489.                            #if defined(PATHNAME_AMIGAOS) || defined(PATHNAME_RISCOS)
  8490.                            if (eq(subdir,S(Kparent))) # für Parent-Directory
  8491.                              {
  8492.                                #ifdef PATHNAME_AMIGAOS
  8493.                                pushSTACK(O(slash_string)); # zusätzliches "/" ans Ende
  8494.                                #endif
  8495.                                #ifdef PATHNAME_RISCOS
  8496.                                pushSTACK(O(parent_string)); # zusätzliches "^" ans Ende
  8497.                                #endif
  8498.                              }
  8499.                              else
  8500.                            #endif
  8501.                            pushSTACK(subdir);
  8502.                           }
  8503.                           pushSTACK(O(null_string)); # und Nullbyte
  8504.                           namestring = string_concat(3); # zusammenhängen
  8505.                           # Information holen:
  8506.                          #if defined(UNIX) || defined(RISCOS) || defined(WIN32_UNIX)
  8507.                          {var struct stat status;
  8508.                           begin_system_call();
  8509.                           if (!( stat(TheAsciz(namestring),&status) ==0))
  8510.                             { if (!(errno==ENOENT)) { OS_error(); }
  8511.                               end_system_call();
  8512.                               # Subdirectory existiert nicht -> OK.
  8513.                             }
  8514.                             else
  8515.                             # File existiert.
  8516.                             { end_system_call();
  8517.                               if (S_ISDIR(status.st_mode)) # Ist es ein Directory?
  8518.                                 # ja -> neuen Pathname dazu bilden:
  8519.                                 { # pathname kopieren und dessen Directory um
  8520.                                   # (car subdir-list) verlängern:
  8521.                                   pushSTACK(Car(STACK_(1+(1+H+2)+1)));
  8522.                                  {var reg1 object pathname = pathname_add_subdir();
  8523.                                   pushSTACK(pathname);
  8524.                                  }# Diesen neuen Pathname vor new-pathname-list pushen:
  8525.                                  {var reg1 object new_cons = allocate_cons();
  8526.                                   Car(new_cons) = STACK_0;
  8527.                                   Cdr(new_cons) = STACK_(H+2+1);
  8528.                                   STACK_(H+2+1) = new_cons;
  8529.                                 }}
  8530.                          }  }
  8531.                          #endif
  8532.                          #ifdef AMIGAOS
  8533.                          { var LONGALIGNTYPE(struct FileInfoBlock) fib;
  8534.                            var reg1 struct FileInfoBlock * fibptr = LONGALIGN(&fib);
  8535.                            set_break_sem_4();
  8536.                            begin_system_call();
  8537.                           {var reg2 BPTR lock = Lock(TheAsciz(namestring),ACCESS_READ);
  8538.                            if (lock==BPTR_NULL)
  8539.                              { if (!(IoErr()==ERROR_OBJECT_NOT_FOUND)) { OS_error(); }
  8540.                                end_system_call();
  8541.                                clr_break_sem_4();
  8542.                                # Subdirectory existiert nicht -> OK.
  8543.                              }
  8544.                              else
  8545.                              # File existiert.
  8546.                              { if (! Examine(lock,fibptr) ) { UnLock(lock); OS_error(); }
  8547.                                UnLock(lock);
  8548.                                end_system_call();
  8549.                                clr_break_sem_4();
  8550.                                if (fibptr->fib_DirEntryType > 0) # Ist es ein Directory?
  8551.                                  # ja -> neuen Pathname dazu bilden:
  8552.                                  { # pathname kopieren und dessen Directory um
  8553.                                    # (car subdir-list) verlängern:
  8554.                                    pushSTACK(Car(STACK_(1+(1+H+2)+1)));
  8555.                                   {var reg1 object pathname = pathname_add_subdir();
  8556.                                    pushSTACK(pathname);
  8557.                                   }# Diesen neuen Pathname vor new-pathname-list pushen:
  8558.                                   {var reg1 object new_cons = allocate_cons();
  8559.                                    Car(new_cons) = STACK_0;
  8560.                                    Cdr(new_cons) = STACK_(H+2+1);
  8561.                                    STACK_(H+2+1) = new_cons;
  8562.                                  }}
  8563.                          }}  }
  8564.                          #endif
  8565.                         }
  8566.                         skipSTACK(1);
  8567.                         goto next_pathname;
  8568.                         #endif
  8569.                 }   }
  8570.               # Um die Task zu erledigen, müssen alle Einträge dieses
  8571.               # Directory abgesucht werden:
  8572.               {{var reg1 object dir_namestring = assure_dir_exists(FALSE); # Links auflösen, Directory-Name bilden
  8573.                 pushSTACK(dir_namestring); # retten
  8574.                }# Stackaufbau: ..., pathname, dir_namestring.
  8575.                #if defined(UNIX) || defined(WIN32_UNIX)
  8576.                 if (!nullp(STACK_(1+5+(1+H+2)+2))) # ;CIRCLE-Flag abfragen
  8577.                   { # pathname in der Hash-Tabelle suchen:
  8578.                     pushSTACK(STACK_0); # Directory-Name
  8579.                     pushSTACK(O(punkt_string)); # und "."
  8580.                     pushSTACK(O(null_string)); # und Nullbyte
  8581.                     {var reg8 object namestring = string_concat(3); # zusammenhängen
  8582.                      var struct stat status;
  8583.                      begin_system_call();
  8584.                      if (!( stat(TheAsciz(namestring),&status) ==0)) # Information holen
  8585.                        { if (!(errno==ENOENT)) { OS_error(); }
  8586.                          end_system_call();
  8587.                          # Eintrag existiert doch nicht (das kann uns
  8588.                          # wohl nur bei symbolischen Links passieren)
  8589.                          # -> wird übergangen
  8590.                          skipSTACK(2); goto next_pathname;
  8591.                        }
  8592.                      end_system_call();
  8593.                      # Eintrag existiert (welch Wunder...)
  8594.                      pushSTACK(UL_to_I(status.st_dev)); # Device-Nummer und
  8595.                      pushSTACK(UL_to_I(status.st_ino)); # Inode-Nummer
  8596.                      {var reg1 object new_cons = allocate_cons(); # zusammenconsen
  8597.                       Cdr(new_cons) = popSTACK(); Car(new_cons) = popSTACK();
  8598.                       # und in der Hash-Tabelle aufsuchen und ablegen:
  8599.                       if (!nullp(shifthash(STACK_(2+2),new_cons,T)))
  8600.                         # war schon drin -> wird übergangen
  8601.                         { skipSTACK(2); goto next_pathname; }
  8602.                   } }}
  8603.                #endif
  8604.                 if (next_task==0)
  8605.                   # Pathname STACK_1 vor result-list pushen:
  8606.                   {var reg1 object new_cons = allocate_cons();
  8607.                    Car(new_cons) = STACK_1;
  8608.                    Cdr(new_cons) = STACK_(4+(1+H+2)+2);
  8609.                    STACK_(4+(1+H+2)+2) = new_cons;
  8610.                   }
  8611.                #if defined(UNIX) || defined(RISCOS) || defined(WIN32_UNIX)
  8612.                { var reg8 object namestring;
  8613.                  #if defined(UNIX) || defined(WIN32_UNIX)
  8614.                  pushSTACK(STACK_0); # Directory-Name
  8615.                  pushSTACK(O(punkt_string)); # und "."
  8616.                  pushSTACK(O(null_string)); # und Nullbyte
  8617.                  namestring = string_concat(3); # zusammenhängen
  8618.                  #endif
  8619.                  #ifdef RISCOS
  8620.                  var reg10 object wildcard_mask;
  8621.                  namestring = copy_string(STACK_0); # Directory-Name
  8622.                  TheSstring(namestring)->data[TheSstring(namestring)->length-1] = '\0'; # mit Nullbyte statt '.' am Schluß
  8623.                  # Statt wildcard_match() selber aufzurufen, überlassen wir das dem Betriebssystem:
  8624.                  pushSTACK(namestring); # retten
  8625.                  wildcard_mask = string_to_asciz(next_task<0 ? Car(STACK_(1+(1+H+2)+3)) : STACK_(2+(1+H+2)+3));
  8626.                  # In wildcard_mask die Wildchar-Characters '?' ins synonyme '#' umwandeln:
  8627.                  { var reg1 uintB* ptr = &TheSstring(wildcard_mask)->data[0];
  8628.                    var reg2 uintL count = TheSstring(wildcard_mask)->length;
  8629.                    dotimespL(count,count, { if (*ptr == '?') { *ptr = '#'; } ptr++; } );
  8630.                  }
  8631.                  namestring = popSTACK();
  8632.                  #endif
  8633.                  # Directory absuchen:
  8634.                 {var reg5 DIR* dirp;
  8635.                  set_break_sem_4();
  8636.                  begin_system_call();
  8637.                  #if defined(UNIX) || defined(WIN32_UNIX)
  8638.                  dirp = opendir(TheAsciz(namestring)); # Directory öffnen
  8639.                  #endif
  8640.                  #ifdef RISCOS
  8641.                  dirp = opendir(TheAsciz(namestring),TheAsciz(wildcard_mask)); # Directory zum Suchen öffnen
  8642.                  #endif
  8643.                  if (dirp == (DIR*)NULL) { OS_error(); }
  8644.                  end_system_call();
  8645.                  loop
  8646.                    { var reg2 SDIRENT* dp;
  8647.                      errno = 0;
  8648.                      begin_system_call();
  8649.                      dp = readdir(dirp); # nächsten Directory-Eintrag holen
  8650.                      end_system_call();
  8651.                      if (dp == (SDIRENT*)NULL) # Error oder Directory zu Ende
  8652.                        { if (!(errno==0
  8653.                                #ifdef WIN32_UNIX
  8654.                                ||errno==ENMFILE
  8655.                                #endif
  8656.                             ) ) { OS_error(); } else break; }
  8657.                      # Directory-Eintrag in String umwandeln:
  8658.                     {var reg4 object direntry;
  8659.                      {var reg3 uintL direntry_len;
  8660.                       #ifdef DIRENT_WITHOUT_NAMLEN
  8661.                       #ifndef DIRENT_RECLEN
  8662.                       #define DIRENT_RECLEN(dp) dp->d_reclen
  8663.                       #endif
  8664.                      
  8665.                       # Unter UNIX_LINUX reicht direntry_len := dp->d_reclen, aber i.a. ist
  8666.                       # direntry_len := min(dp->d_reclen,asciz_length(dp->d_name))  nötig:
  8667.                       {var reg1 const uintB* ptr = (const uintB*)(&dp->d_name[0]);
  8668.                        var reg1 uintL count;
  8669.                        direntry_len = 0;
  8670.                        dotimesL(count,DIRENT_RECLEN(dp),
  8671.                          { if (*ptr == '\0') break;
  8672.                            ptr++; direntry_len++;
  8673.                          });
  8674.                       }
  8675.                       #else
  8676.                       direntry_len = dp->d_namlen;
  8677.                       #endif
  8678.                       direntry = make_string((const uintB*)(&dp->d_name[0]),direntry_len);
  8679.                      }
  8680.                      #ifndef RISCOS
  8681.                      # "." und ".." übergehen:
  8682.                      if (!(equal(direntry,O(punkt_string))
  8683.                            || equal(direntry,O(punktpunkt_string))
  8684.                         ) )
  8685.                      #endif
  8686.                        { pushSTACK(direntry);
  8687.                          # Stackaufbau: ..., pathname, dir_namestring, direntry.
  8688.                          # Feststellen, ob es ein Directory oder ein File ist:
  8689.                          pushSTACK(STACK_1); # Directory-Namestring
  8690.                          pushSTACK(direntry); # direntry
  8691.                          pushSTACK(O(null_string)); # und Nullbyte
  8692.                         {var reg3 object namestring = string_concat(3); # zusammenhängen
  8693.                          # Information holen:
  8694.                          var struct stat status;
  8695.                          begin_system_call();
  8696.                          if (!( stat(TheAsciz(namestring),&status) ==0))
  8697.                            { if (!(errno==ENOENT ||errno==ELOOP_VALUE
  8698.                                    #ifdef EACCES # WIN32_UNIX, DJGPP2
  8699.                                    ||errno==EACCES
  8700.                                    #endif
  8701.                                 ) ) { OS_error(); }
  8702.                              end_system_call();
  8703.                              # Eintrag existiert doch nicht (das kann uns
  8704.                              # wohl nur bei symbolischen Links passieren)
  8705.                              # -> wird übergangen
  8706.                            }
  8707.                            else
  8708.                            { end_system_call();
  8709.                              # Eintrag existiert (welch Wunder...)
  8710.                              if (S_ISDIR(status.st_mode)) # Ist es ein Directory?
  8711.                                # Eintrag ist ein Directory.
  8712.                                { if (recursively) # alle rekursiven Subdirectories gewünscht?
  8713.                                    # ja -> zu einem Pathname machen und auf
  8714.                                    # pathnames-to-insert pushen (wird nachher
  8715.                                    # vor pathname-list-rest eingefügt):
  8716.                                    { pushSTACK(STACK_2); pushSTACK(STACK_(0+1)); # pathname und direntry
  8717.                                     {var reg1 object pathname = pathname_add_subdir();
  8718.                                      pushSTACK(pathname);
  8719.                                     }# Diesen neuen Pathname vor pathname-to-insert pushen:
  8720.                                     {var reg1 object new_cons = allocate_cons();
  8721.                                      Car(new_cons) = popSTACK();
  8722.                                      Cdr(new_cons) = STACK_(0+3);
  8723.                                      STACK_(0+3) = new_cons;
  8724.                                    }}
  8725.                                  if (next_task<0)
  8726.                                    {
  8727.                                      #ifndef RISCOS
  8728.                                      # (car subdir-list) mit direntry matchen:
  8729.                                      if (wildcard_match(Car(STACK_(1+(1+H+2)+3)),STACK_0))
  8730.                                      #endif
  8731.                                        # Subdirectory matcht -> zu einem Pathname
  8732.                                        # machen und auf new-pathname-list pushen:
  8733.                                        { pushSTACK(STACK_2); pushSTACK(STACK_(0+1)); # pathname und direntry
  8734.                                         {var reg1 object pathname = pathname_add_subdir();
  8735.                                          pushSTACK(pathname);
  8736.                                         }# Diesen neuen Pathname vor new-pathname-list pushen:
  8737.                                         {var reg1 object new_cons = allocate_cons();
  8738.                                          Car(new_cons) = popSTACK();
  8739.                                          Cdr(new_cons) = STACK_(H+2+3);
  8740.                                          STACK_(H+2+3) = new_cons;
  8741.                                    }   }}
  8742.                                }
  8743.                                else
  8744.                                # Eintrag ist ein (halbwegs) normales File.
  8745.                                { if (next_task>0)
  8746.                                    {
  8747.                                      #ifndef RISCOS
  8748.                                      # name&type mit direntry matchen:
  8749.                                      if (wildcard_match(STACK_(2+(1+H+2)+3),STACK_0))
  8750.                                      #endif
  8751.                                        # File matcht -> zu einem Pathname machen
  8752.                                        # und auf result-list pushen:
  8753.                                        {
  8754.                                          #ifndef PATHNAME_RISCOS
  8755.                                          pushSTACK(STACK_0); # direntry
  8756.                                          split_name_type(1); # in Name und Typ aufspalten
  8757.                                          {var reg1 object pathname = copy_pathname(STACK_(2+2));
  8758.                                           ThePathname(pathname)->pathname_type = popSTACK(); # Typ einsetzen
  8759.                                           ThePathname(pathname)->pathname_name = popSTACK(); # Name einsetzen
  8760.                                           pushSTACK(pathname);
  8761.                                           pushSTACK(pathname);
  8762.                                          }
  8763.                                          #else # PATHNAME_RISCOS
  8764.                                          {var reg1 object pathname = copy_pathname(STACK_2);
  8765.                                           pushSTACK(pathname);
  8766.                                           if (name_and_type && nullp(ThePathname(pathname)->pathname_type))
  8767.                                             # Move the last subdir into the type slot of the pathname.
  8768.                                             { # subdirs := (butlast subdirs) = (nreverse (cdr (reverse subdirs)))
  8769.                                               var reg1 object subdirs = reverse(ThePathname(pathname)->pathname_directory);
  8770.                                               pathname = STACK_0;
  8771.                                               ThePathname(pathname)->pathname_type = Car(subdirs);
  8772.                                               ThePathname(pathname)->pathname_directory = nreverse(Cdr(subdirs));
  8773.                                             }
  8774.                                           ThePathname(pathname)->pathname_name = STACK_1; # direntry
  8775.                                           pushSTACK(pathname);
  8776.                                          }
  8777.                                          #endif
  8778.                                          # Truename bilden (symbolische Links auflösen):
  8779.                                          assure_dir_exists(FALSE);
  8780.                                          if (file_exists(_EMA_)) # falls File (immer noch...) existiert
  8781.                                            { if (!nullp(STACK_(0+5+(1+H+2)+3+2))) # :FULL gewünscht?
  8782.                                                with_stat_info(); # ja -> STACK_0 erweitern
  8783.                                              # und STACK_0 vor result-list pushen:
  8784.                                             {var reg1 object new_cons = allocate_cons();
  8785.                                              Car(new_cons) = STACK_0;
  8786.                                              Cdr(new_cons) = STACK_(4+(1+H+2)+3+2);
  8787.                                              STACK_(4+(1+H+2)+3+2) = new_cons;
  8788.                                            }}
  8789.                                          skipSTACK(2);
  8790.                                    }   }
  8791.                            }   }
  8792.                          skipSTACK(1); # direntry vergessen
  8793.                    }}  }}
  8794.                  begin_system_call();
  8795.                  if (CLOSEDIR(dirp)) { OS_error(); }
  8796.                  end_system_call();
  8797.                  clr_break_sem_4();
  8798.                }}
  8799.                #endif
  8800.                #ifdef AMIGAOS
  8801.                 # Directory absuchen:
  8802.                { var reg7 object namestring = OSnamestring(STACK_0);
  8803.                  set_break_sem_4();
  8804.                  begin_system_call();
  8805.                 {var reg6 BPTR lock = Lock(TheAsciz(namestring),ACCESS_READ);
  8806.                  var LONGALIGNTYPE(struct FileInfoBlock) fib;
  8807.                  var reg5 struct FileInfoBlock * fibptr = LONGALIGN(&fib);
  8808.                  if (lock==BPTR_NULL) { OS_error(); }
  8809.                  if (! Examine(lock,fibptr) ) { OS_error(); }
  8810.                  end_system_call();
  8811.                  loop
  8812.                    { begin_system_call();
  8813.                      if (! ExNext(lock,fibptr) ) # Error oder Directory zu Ende?
  8814.                        break;
  8815.                      end_system_call();
  8816.                      # Directory-Eintrag in String umwandeln:
  8817.                     {var reg4 object direntry = asciz_to_string(&fibptr->fib_FileName[0]);
  8818.                      pushSTACK(direntry);
  8819.                      # Stackaufbau: ..., pathname, dir_namestring, direntry.
  8820.                      # Feststellen, ob es ein Directory oder ein File ist:
  8821.                      if ((fibptr->fib_DirEntryType > 0)
  8822.                          && (fibptr->fib_DirEntryType != ST_SOFTLINK)) # Ist es ein Directory?
  8823.                        # Eintrag ist ein Directory.
  8824.                        { if (recursively) # alle rekursiven Subdirectories gewünscht?
  8825.                            # ja -> zu einem Pathname machen und auf
  8826.                            # pathnames-to-insert pushen (wird nachher
  8827.                            # vor pathname-list-rest eingefügt):
  8828.                            { pushSTACK(STACK_2); pushSTACK(STACK_(0+1)); # pathname und direntry
  8829.                             {var reg1 object pathname = pathname_add_subdir();
  8830.                              pushSTACK(pathname);
  8831.                             }# Diesen neuen Pathname vor pathname-to-insert pushen:
  8832.                             {var reg1 object new_cons = allocate_cons();
  8833.                              Car(new_cons) = popSTACK();
  8834.                              Cdr(new_cons) = STACK_(0+3);
  8835.                              STACK_(0+3) = new_cons;
  8836.                            }}
  8837.                          if (next_task<0)
  8838.                            { # (car subdir-list) mit direntry matchen:
  8839.                              if (wildcard_match(Car(STACK_(1+(1+H+2)+3)),STACK_0))
  8840.                                # Subdirectory matcht -> zu einem Pathname
  8841.                                # machen und auf new-pathname-list pushen:
  8842.                                { pushSTACK(STACK_2); pushSTACK(STACK_(0+1)); # pathname und direntry
  8843.                                 {var reg1 object pathname = pathname_add_subdir();
  8844.                                  pushSTACK(pathname);
  8845.                                 }# Diesen neuen Pathname vor new-pathname-list pushen:
  8846.                                 {var reg1 object new_cons = allocate_cons();
  8847.                                  Car(new_cons) = popSTACK();
  8848.                                  Cdr(new_cons) = STACK_(H+2+3);
  8849.                                  STACK_(H+2+3) = new_cons;
  8850.                            }   }}
  8851.                        }
  8852.                        else
  8853.                        # Eintrag ist ein (halbwegs) normales File.
  8854.                        { if (next_task>0)
  8855.                            { # name&type mit direntry matchen:
  8856.                              if (wildcard_match(STACK_(2+(1+H+2)+3),STACK_0))
  8857.                                # File matcht -> zu einem Pathname machen
  8858.                                # und auf result-list pushen:
  8859.                                { pushSTACK(STACK_0); # direntry
  8860.                                  split_name_type(1); # in Name und Typ aufspalten
  8861.                                 {var reg1 object pathname = copy_pathname(STACK_(2+2));
  8862.                                  ThePathname(pathname)->pathname_type = popSTACK(); # Typ einsetzen
  8863.                                  ThePathname(pathname)->pathname_name = popSTACK(); # Name einsetzen
  8864.                                  pushSTACK(pathname);
  8865.                                  pushSTACK(pathname);
  8866.                                 }
  8867.                                 assure_dir_exists(FALSE); # Truename bilden (symbolische Links auflösen)
  8868.                                 { if (!nullp(STACK_(0+5+(1+H+2)+3+2))) # :FULL gewünscht?
  8869.                                     with_stat_info(); # ja -> STACK_0 erweitern
  8870.                                   # und STACK_0 vor result-list pushen:
  8871.                                  {var reg1 object new_cons = allocate_cons();
  8872.                                   Car(new_cons) = STACK_0;
  8873.                                   Cdr(new_cons) = STACK_(4+(1+H+2)+3+2);
  8874.                                   STACK_(4+(1+H+2)+3+2) = new_cons;
  8875.                                 }}
  8876.                                 skipSTACK(2);
  8877.                        }   }   }
  8878.                      skipSTACK(1); # direntry vergessen
  8879.                    }}
  8880.                  UnLock(lock);
  8881.                  if (!(IoErr()==ERROR_NO_MORE_ENTRIES)) { OS_error(); }
  8882.                  end_system_call();
  8883.                  clr_break_sem_4();
  8884.                }}
  8885.                #endif
  8886.                #if defined(MSDOS) && !defined(WIN32_DOS)
  8887.                 pushSTACK(STACK_0); # Directory-Name
  8888.                 pushSTACK(O(wild_wild_string)); # und "*.*"
  8889.                 pushSTACK(O(null_string)); # und Nullbyte
  8890.                {var reg8 object namestring = string_concat(3); # zusammenhängen
  8891.                 # Directory absuchen, gemäß DOS-Konvention:
  8892.                 var struct ffblk DTA_buffer;
  8893.                 set_break_sem_4(); # wegen DTA-Buffer gegen Unterbrechungen sperren
  8894.                 # Suchanfang, suche nach Ordnern und normalen Dateien:
  8895.                 begin_system_call();
  8896.                 if (findfirst(TheAsciz(namestring),&DTA_buffer,FA_DIREC|FA_ARCH|FA_RDONLY) <0)
  8897.                   { if (!((errno==ENOENT) 
  8898.                        || (errno==ENOMORE)
  8899.                        ) ) { OS_error(); } }
  8900.                   else # Keine Datei gefunden -> Schleife nicht durchlaufen
  8901.                   loop
  8902.                     { end_system_call();
  8903.                      {# Directory-Eintrag in String umwandeln:
  8904.                       var reg4 object direntry = asciz_to_string(&DTA_buffer.ff_name[0]);
  8905.                       # "." und ".." übergehen:
  8906.                       if (!(equal(direntry,O(punkt_string))
  8907.                             || equal(direntry,O(punktpunkt_string))
  8908.                          ) )
  8909.                         { pushSTACK(direntry);
  8910.                           # Stackaufbau: ..., pathname, dir_namestring, direntry.
  8911.                           if (DTA_buffer.ff_attrib & FA_DIREC) # Ist es ein Directory?
  8912.                             # Eintrag ist ein Directory.
  8913.                             { if (recursively) # alle rekursiven Subdirectories gewünscht?
  8914.                                 # ja -> zu einem Pathname machen und auf
  8915.                                 # pathnames-to-insert pushen (wird nachher
  8916.                                 # vor pathname-list-rest eingefügt):
  8917.                                 { pushSTACK(STACK_2); pushSTACK(STACK_(0+1)); # pathname und direntry
  8918.                                  {var reg1 object pathname = pathname_add_subdir();
  8919.                                   pushSTACK(pathname);
  8920.                                  }# Diesen neuen Pathname vor pathname-to-insert pushen:
  8921.                                  {var reg1 object new_cons = allocate_cons();
  8922.                                   Car(new_cons) = popSTACK();
  8923.                                   Cdr(new_cons) = STACK_(0+3);
  8924.                                   STACK_(0+3) = new_cons;
  8925.                                 }}
  8926.                               if (next_task<0)
  8927.                                 { # (car subdir-list) mit direntry matchen:
  8928.                                   if (wildcard_match(Car(STACK_(1+(1+H+2)+3)),STACK_0))
  8929.                                     # Subdirectory matcht -> zu einem Pathname
  8930.                                     # machen und auf new-pathname-list pushen:
  8931.                                     { pushSTACK(STACK_2); pushSTACK(STACK_(0+1)); # pathname und direntry
  8932.                                      {var reg1 object pathname = pathname_add_subdir();
  8933.                                       pushSTACK(pathname);
  8934.                                      }# Diesen neuen Pathname vor new-pathname-list pushen:
  8935.                                      {var reg1 object new_cons = allocate_cons();
  8936.                                       Car(new_cons) = popSTACK();
  8937.                                       Cdr(new_cons) = STACK_(H+2+3);
  8938.                                       STACK_(H+2+3) = new_cons;
  8939.                                 }   }}
  8940.                             }
  8941.                             else
  8942.                             # Eintrag ist ein (halbwegs) normales File.
  8943.                             { if (next_task>0)
  8944.                                 { # name&type mit direntry matchen:
  8945.                                   if (wildcard_match(STACK_(2+(1+H+2)+3),STACK_0))
  8946.                                     # File matcht -> zu einem Pathname machen
  8947.                                     # und auf result-list pushen:
  8948.                                     { pushSTACK(STACK_0); # direntry
  8949.                                       split_name_type(1); # in Name und Typ aufspalten
  8950.                                      {var reg1 object new = copy_pathname(STACK_(2+2));
  8951.                                       ThePathname(new)->pathname_type = popSTACK(); # Typ einsetzen
  8952.                                       ThePathname(new)->pathname_name = popSTACK(); # Name einsetzen
  8953.                                       # Full-Flag abtesten und evtl. mehr Information besorgen:
  8954.                                       if (!nullp(STACK_(0+5+(1+H+2)+3))) # :FULL gewünscht?
  8955.                                         { pushSTACK(new); # newpathname als 1. Listenelement
  8956.                                           pushSTACK(new); # newpathname als 2. Listenelement
  8957.                                           { # Uhrzeit und Datum von DOS-Format in Decoded-Time umwandeln:
  8958.                                             var decoded_time timepoint;
  8959.                                             convert_timedate((uintW)DTA_buffer.ff_ftime,(uintW)DTA_buffer.ff_fdate,
  8960.                                                              &timepoint);
  8961.                                             pushSTACK(timepoint.Sekunden);
  8962.                                             pushSTACK(timepoint.Minuten);
  8963.                                             pushSTACK(timepoint.Stunden);
  8964.                                             pushSTACK(timepoint.Tag);
  8965.                                             pushSTACK(timepoint.Monat);
  8966.                                             pushSTACK(timepoint.Jahr);
  8967.                                             new = listof(6); # 6-elementige Liste bauen
  8968.                                           }
  8969.                                           pushSTACK(new); # als 3. Listenelement
  8970.                                           pushSTACK(UL_to_I(*(uintL*)(&DTA_buffer.ff_fsize))); # Länge als 4. Listenelement
  8971.                                           new = listof(4); # 4-elementige Liste bauen
  8972.                                         }
  8973.                                       pushSTACK(new);
  8974.                                      }# und STACK_0 vor result-list pushen:
  8975.                                      {var reg1 object new_cons = allocate_cons();
  8976.                                       Car(new_cons) = popSTACK();
  8977.                                       Cdr(new_cons) = STACK_(4+(1+H+2)+3);
  8978.                                       STACK_(4+(1+H+2)+3) = new_cons;
  8979.                             }   }   }}
  8980.                           skipSTACK(1); # direntry vergessen
  8981.                         }
  8982.                       # nächstes File:
  8983.                       begin_system_call();
  8984.                       if (findnext(&DTA_buffer) <0)
  8985.                         { if (!((errno==ENOENT) 
  8986.                              || (errno==ENOMORE)
  8987.                              ) ) { OS_error(); }
  8988.                           break; # Keine weitere Datei -> Schleifenende
  8989.                         }
  8990.                     }}
  8991.                 end_system_call();
  8992.                 clr_break_sem_4();
  8993.                }
  8994.                #elif defined(WIN32_DOS)
  8995.                 pushSTACK(STACK_0); # Directory-Name
  8996.                 pushSTACK(O(wild_wild_string)); # und "*.*"
  8997.                 pushSTACK(O(null_string)); # und Nullbyte
  8998.                {var reg8 object namestring = string_concat(3); # zusammenhängen
  8999.                 var WIN32_FIND_DATA ffd;
  9000.                 var HANDLE hFindFile;
  9001.                 set_break_sem_4(); # wegen DTA-Buffer gegen Unterbrechungen sperren
  9002.                 # Suchanfang, suche nach Ordnern und normalen Dateien:
  9003.                 begin_system_call();
  9004.                 if ((hFindFile=FindFirstFile(TheAsciz(namestring),&ffd)) == INVALID_HANDLE_VALUE)
  9005.                   { OS_error(); }
  9006.                  else # Keine Datei gefunden -> Schleife nicht durchlaufen
  9007.                  loop
  9008.                    { # Stackaufbau: ..., next-pathname.
  9009.                      end_system_call();
  9010.                      {# Directory-Eintrag in String umwandeln:
  9011.                       var reg4 object direntry = asciz_to_string(&ffd.cFileName[0]);
  9012.                       # "." und ".." übergehen:
  9013.                       if (!(equal(direntry,O(punkt_string))
  9014.                             || equal(direntry,O(punktpunkt_string))
  9015.                          ) )
  9016.                         { pushSTACK(direntry);
  9017.                           # Stackaufbau: ..., pathname, dir_namestring, direntry.
  9018.                           if (ffd.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) # Ist es ein Directory?
  9019.                             # Eintrag ist ein Directory.
  9020.                             { if (recursively) # alle rekursiven Subdirectories gewünscht?
  9021.                                 # ja -> zu einem Pathname machen und auf
  9022.                                 # pathnames-to-insert pushen (wird nachher
  9023.                                 # vor pathname-list-rest eingefügt):
  9024.                                 { pushSTACK(STACK_2); pushSTACK(STACK_(0+1)); # pathname und direntry
  9025.                                  {var reg1 object pathname = pathname_add_subdir();
  9026.                                   pushSTACK(pathname);
  9027.                                  }# Diesen neuen Pathname vor pathname-to-insert pushen:
  9028.                                  {var reg1 object new_cons = allocate_cons();
  9029.                                   Car(new_cons) = popSTACK();
  9030.                                   Cdr(new_cons) = STACK_(0+3);
  9031.                                   STACK_(0+3) = new_cons;
  9032.                                 }}
  9033.                               if (next_task<0)
  9034.                                 { # (car subdir-list) mit direntry matchen:
  9035.                                   if (wildcard_match(Car(STACK_(1+(1+H+2)+3)),STACK_0))
  9036.                                     # Subdirectory matcht -> zu einem Pathname
  9037.                                     # machen und auf new-pathname-list pushen:
  9038.                                     { pushSTACK(STACK_2); pushSTACK(STACK_(0+1)); # pathname und direntry
  9039.                                      {var reg1 object pathname = pathname_add_subdir();
  9040.                                       pushSTACK(pathname);
  9041.                                      }# Diesen neuen Pathname vor new-pathname-list pushen:
  9042.                                      {var reg1 object new_cons = allocate_cons();
  9043.                                       Car(new_cons) = popSTACK();
  9044.                                       Cdr(new_cons) = STACK_(H+2+3);
  9045.                                       STACK_(H+2+3) = new_cons;
  9046.                                 }   }}
  9047.                             }
  9048.                             else
  9049.                             # Eintrag ist ein (halbwegs) normales File.
  9050.                             { if (next_task>0)
  9051.                                 { # name&type mit direntry matchen:
  9052.                                   if (wildcard_match(STACK_(2+(1+H+2)+3),STACK_0))
  9053.                                     # File matcht -> zu einem Pathname machen
  9054.                                     # und auf result-list pushen:
  9055.                                     { pushSTACK(STACK_0); # direntry
  9056.                                       split_name_type(1); # in Name und Typ aufspalten
  9057.                                      {var reg1 object new = copy_pathname(STACK_(2+2));
  9058.                                       ThePathname(new)->pathname_type = popSTACK(); # Typ einsetzen
  9059.                                       ThePathname(new)->pathname_name = popSTACK(); # Name einsetzen
  9060.                                       # Full-Flag abtesten und evtl. mehr Information besorgen:
  9061.                                       if (!nullp(STACK_(0+5+(1+H+2)+3))) # :FULL gewünscht?
  9062.                                         { pushSTACK(new); # newpathname als 1. Listenelement
  9063.                                           pushSTACK(new); # newpathname als 2. Listenelement
  9064.                                           { # Uhrzeit und Datum von DOS-Format in Decoded-Time umwandeln:
  9065.                                             var decoded_time timepoint;
  9066.                                             var WORD date;
  9067.                                             var WORD time;
  9068.                                             FileTimeToDosDateTime(&ffd.ftLastWriteTime,&date,&time);
  9069.                                             convert_timedate((uintW)time,(uintW)date,&timepoint);
  9070.                                             pushSTACK(timepoint.Sekunden);
  9071.                                             pushSTACK(timepoint.Minuten);
  9072.                                             pushSTACK(timepoint.Stunden);
  9073.                                             pushSTACK(timepoint.Tag);
  9074.                                             pushSTACK(timepoint.Monat);
  9075.                                             pushSTACK(timepoint.Jahr);
  9076.                                             new = listof(6); # 6-elementige Liste bauen
  9077.                                           }
  9078.                                           pushSTACK(new); # als 3. Listenelement
  9079.                                           pushSTACK(UL_to_I(*(uintL*)(&ffd.nFileSizeLow))); # Länge als 4. Listenelement
  9080.                                           new = listof(4); # 4-elementige Liste bauen
  9081.                                         }
  9082.                                       pushSTACK(new);
  9083.                                      }# und STACK_0 vor result-list pushen:
  9084.                                      {var reg1 object new_cons = allocate_cons();
  9085.                                       Car(new_cons) = popSTACK();
  9086.                                       Cdr(new_cons) = STACK_(4+(1+H+2)+3);
  9087.                                       STACK_(4+(1+H+2)+3) = new_cons;
  9088.                             }   }   }}
  9089.                           skipSTACK(1); # direntry vergessen
  9090.                         }
  9091.                       # nächstes File:
  9092.                       begin_system_call();
  9093.                       if (FindNextFile(hFindFile,&ffd) == FALSE)
  9094.                         { if (GetLastError() != ERROR_NO_MORE_FILES) 
  9095.                             { OS_error(); }
  9096.                           break; # Keine weitere Datei -> Schleifenende
  9097.                         }
  9098.                     }}
  9099.                 end_system_call();
  9100.                 clr_break_sem_4();
  9101.                }
  9102.                #endif
  9103.               }
  9104.               skipSTACK(2); # pathname und dir-namestring vergessen
  9105.               next_pathname: ;
  9106.              }# Stackaufbau: ..., new-pathname-list, [ht,] pathname-list-rest, pathnames-to-insert.
  9107.               # Vor dem Weiterrücken mit pathname-list-rest :
  9108.               # pathname-list-rest := (nreconc pathnames-to-insert pathname-list-rest) :
  9109.              {var reg1 object pathnames_to_insert = popSTACK();
  9110.               STACK_0 = nreconc(pathnames_to_insert,STACK_0);
  9111.             }}
  9112.           skipSTACK(H+1); # leere pathname-list-rest und evtl. Hash-Tabelle vergessen
  9113.           #undef H
  9114.           # new-pathname-list umdrehen, ersetzt die geleerte pathname-list:
  9115.           {var reg1 object new_pathname_list = popSTACK();
  9116.            STACK_0 = nreverse(new_pathname_list); # neue pathname-list
  9117.           }
  9118.           # Mit dieser Subdir-Stufe sind wir fertig.
  9119.           if (matomp(STACK_1)) break; # (atom subdir-list) -> fertig.
  9120.           recursively = FALSE; # die nächste (vorläufig) nicht-rekursiv
  9121.           passed_subdir: ;
  9122.         }}
  9123.       # Stackaufbau: result-list, pathname, name&type, subdir-list, pathname-list.
  9124.       # subdir-list ist =NIL geworden, auch pathname-list = NIL (denn beim
  9125.       # letzten Schleifendurchlauf ist immer next_task=0,1,2, und dadurch
  9126.       # wurde nichts auf new-pathname-list gepusht).
  9127.       skipSTACK(4);
  9128.       return popSTACK(); # result-list als Ergebnis
  9129.     }}
  9130.   #
  9131.   #endif # PATHNAME_NOEXT
  9132.  
  9133. LISPFUN(directory,0,1,norest,key,2, (kw(circle),kw(full)) )
  9134. # (DIRECTORY [pathname [:circle] [:full]]), CLTL S. 427
  9135.   { # Stackaufbau: pathname, circle, full.
  9136.     #if defined(UNIX) || defined(WIN32_UNIX)
  9137.     # :CIRCLE-Argument hat Defaultwert NIL:
  9138.     if (eq(STACK_1,unbound)) { STACK_1 = NIL; }
  9139.     #endif
  9140.     # :FULL-Argument hat Defaultwert NIL:
  9141.     if (eq(STACK_0,unbound)) { STACK_0 = NIL; }
  9142.     # Pathname-Argument überprüfen:
  9143.    {var reg1 object pathname = STACK_2;
  9144.     if (eq(pathname,unbound))
  9145.       {
  9146.         #ifdef PATHNAME_EXT83
  9147.         pathname = O(wild_wild_string); # Default ist "*.*" bzw. "*.*;*"
  9148.         #endif
  9149.         #if defined(PATHNAME_NOEXT) || defined(PATHNAME_RISCOS)
  9150.         pathname = O(wild_string); # Default ist "*"
  9151.         #endif
  9152.       }
  9153.     pathname = coerce_pathname(pathname); # zu einem Pathname machen
  9154.     # Los geht's:
  9155.     #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  9156.     if (eq(ThePathname(pathname)->pathname_device,S(Kwild))) # Device = :WILD ?
  9157.       # alle Devices abzusuchen
  9158.       { STACK_2 = pathname;
  9159.         pushSTACK(NIL); # bisherige Pathname-Liste := NIL
  9160.         pushSTACK(STACK_(0+1)); # full (für directory_search)
  9161.         # Stackaufbau: pathname, circle, full, pathname-list, full.
  9162.         {var uintB drive;
  9163.          for (drive='A'; drive<='Z'; drive++) # alle Drives durchlaufen
  9164.            if (good_drive(drive))
  9165.              { pushSTACK(make_string(&drive,1)); # Device, einelementiger String
  9166.               {var reg2 object newpathname = copy_pathname(STACK_(2+2+1)); # Pathname kopieren
  9167.                ThePathname(newpathname)->pathname_device = popSTACK(); # Drive übernehmen
  9168.                # innerhalb eines Laufwerks suchen:
  9169.                {var reg3 object newpathnames = directory_search(newpathname);
  9170.                 # und Pathname-Liste vor STACK_1 hängen:
  9171.                 STACK_1 = nreconc(newpathnames,STACK_1);
  9172.         }    }}}
  9173.         value1 = nreverse(STACK_1); # Pathname-Liste wieder umdrehen
  9174.         skipSTACK(3+2);
  9175.       }
  9176.       else
  9177.       # nur ein Device abzusuchen
  9178.     #endif
  9179.       { value1 = directory_search(pathname); # matchende Pathnames bilden
  9180.         skipSTACK(3);
  9181.       }
  9182.     mv_count=1;
  9183.   }}
  9184.  
  9185. LISPFUN(cd,0,1,norest,nokey,0,NIL)
  9186. # (CD [pathname]) setzt das aktuelle Laufwerk und das aktuelle Directory.
  9187.   { var reg1 object pathname = popSTACK();
  9188.     if (eq(pathname,unbound)) { pathname = O(leer_string); } # "" als Default
  9189.     pathname = coerce_pathname(pathname); # zu einem Pathname machen
  9190.     # kopieren und Name und Typ auf NIL setzen:
  9191.     pathname = copy_pathname(pathname);
  9192.     ThePathname(pathname)->pathname_name = NIL;
  9193.     ThePathname(pathname)->pathname_type = NIL;
  9194.     check_no_wildcards(pathname); # mit Wildcards -> Fehler
  9195.     pathname = use_default_dir(pathname); # Pathname mit Seriennummer draus machen
  9196.     pushSTACK(pathname);
  9197.     assure_dir_exists(FALSE); # Directory muß existieren
  9198.     change_default(); # Default-Drive, Default-Directory setzen
  9199.     value1 = popSTACK(); mv_count=1; # neuer pathname als Wert
  9200.   }
  9201.  
  9202. # UP: Überprüft ein Pathname-Argument, ob Name und Typ beide =NIL sind,
  9203. # und ob das Directory "fast" existiert.
  9204. # shorter_directory_arg()
  9205. # > STACK_0 : Pathname-Argument
  9206. #if defined(MSDOS)
  9207. # < ergebnis: Directory-Namestring (für DOS, ASCIZ, ohne '\' am Schluß)
  9208. #endif
  9209. #if defined(UNIX) || defined(AMIGAOS) || defined(WIN32_UNIX)
  9210. # < ergebnis: Directory-Namestring (fürs OS, ASCIZ, ohne '/' am Schluß)
  9211. #endif
  9212. #if defined(RISCOS)
  9213. # < ergebnis: Directory-Namestring (fürs OS, ASCIZ, ohne '.' am Schluß)
  9214. #endif
  9215. # Erhöht STACK um 1.
  9216. # kann GC auslösen
  9217.   local object shorter_directory_arg (void);
  9218.   local object shorter_directory_arg()
  9219.     { var reg1 object pathname = coerce_pathname(popSTACK()); # Argument zu einem Pathname machen
  9220.       check_no_wildcards(pathname); # mit Wildcards -> Fehler
  9221.       pathname = use_default_dir(pathname); # Default-Directory einfügen
  9222.       # Überprüfe, ob Name=NIL und Typ=NIL :
  9223.       if (!(nullp(ThePathname(pathname)->pathname_name)
  9224.             && nullp(ThePathname(pathname)->pathname_type)
  9225.          ) )
  9226.         { pushSTACK(pathname); # Wert für Slot PATHNAME von FILE-ERROR
  9227.           pushSTACK(pathname);
  9228.           //: DEUTSCH "Das ist keine Directory-Angabe: ~"
  9229.           //: ENGLISH "not a directory: ~"
  9230.           //: FRANCAIS "Ceci ne désigne pas un répertoire : ~"
  9231.           fehler(file_error, GETTEXT("not a directory: ~"));
  9232.         }
  9233.       pushSTACK(pathname); # neuen Pathname retten
  9234.       # verkürze das Directory:
  9235.       {var reg2 object subdirs = ThePathname(pathname)->pathname_directory;
  9236.        if (nullp(Cdr(subdirs))) # Root-Directory ?
  9237.          { baddir:
  9238.            # STACK_0 = pathname, Wert für Slot PATHNAME von FILE-ERROR
  9239.            pushSTACK(STACK_0);
  9240.            //: DEUTSCH "Hier sind nur echte Unterdirectories zulässig, nicht ~"
  9241.            //: ENGLISH "root directory not allowed here: ~"
  9242.            //: FRANCAIS "Le répertoire racine n'est pas permis ici : ~"
  9243.            fehler(file_error, GETTEXT("root directory not allowed here: ~"));
  9244.          }
  9245.        subdirs = reverse(subdirs); # Liste kopieren und dabei umdrehen
  9246.        #if defined(PATHNAME_AMIGAOS) || defined(PATHNAME_RISCOS)
  9247.        if (eq(Car(subdirs),S(Kparent))) # letztes Subdir muß /= :PARENT sein
  9248.          goto baddir;
  9249.        #endif
  9250.        pushSTACK(subdirs); # Cons mit letztem Subdir als CAR retten
  9251.        subdirs = Cdr(subdirs); # alle Subdirs bis aufs letzte
  9252.        subdirs = nreverse(subdirs); # wieder in die richtige Reihenfolge bringen
  9253.        pathname = STACK_1;
  9254.        ThePathname(pathname)->pathname_directory = subdirs; # und in den Pathname setzen
  9255.        # Dieses Directory muß existieren:
  9256.        pushSTACK(pathname);
  9257.        # Stackaufbau: pathname, subdircons, pathname.
  9258.        {var reg3 object dir_namestring = assure_dir_exists(FALSE);
  9259.         # Baue ASCIZ-String des Subdir für OS:
  9260.         STACK_0 = dir_namestring; # bisheriger Directory-Namestring als 1. String
  9261.         {var reg4 uintC stringcount =
  9262.            subdir_namestring_parts(STACK_1); # und Strings zum letzten Subdir
  9263.          # und kein '\' am Schluß (für DOS)
  9264.          # und kein '/' am Schluß (fürs OS)
  9265.          pushSTACK(O(null_string)); # und Nullbyte als letzten String
  9266.          {var reg5 object dirstring = string_concat(1+stringcount+1); # zusammenhängen
  9267.           skipSTACK(2);
  9268.           return dirstring;
  9269.     } }}}}
  9270.  
  9271. LISPFUNN(make_dir,1)
  9272. # (MAKE-DIR pathname) legt ein neues Unterdirectory pathname an.
  9273.   { var reg1 object pathstring = shorter_directory_arg();
  9274.     #ifdef AMIGAOS
  9275.     set_break_sem_4();
  9276.     begin_system_call();
  9277.     {var reg2 BPTR lock = CreateDir(TheAsciz(pathstring)); # Unterdirectory erzeugen
  9278.      if (lock==BPTR_NULL) { OS_error(); }
  9279.      UnLock(lock); # Lock freigeben
  9280.     }
  9281.     end_system_call();
  9282.     clr_break_sem_4();
  9283.     #endif
  9284.     #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_DOS) || defined(WIN32_UNIX)
  9285.     begin_system_call();
  9286.     if (mkdir(TheAsciz(pathstring),0777)) # Unterdirectory erzeugen
  9287.       { OS_error(); }
  9288.     end_system_call();
  9289.     #endif
  9290.     value1 = T; mv_count=1; # 1 Wert T
  9291.   }
  9292.  
  9293. LISPFUNN(delete_dir,1)
  9294. # (DELETE-DIR pathname) entfernt das Unterdirectory pathname.
  9295.   { var reg1 object pathstring = shorter_directory_arg();
  9296.     #ifdef AMIGAOS
  9297.     # Noch Test, ob's auch ein Directory und kein File ist??
  9298.     begin_system_call();
  9299.     if (! DeleteFile(TheAsciz(pathstring)) ) # Unterdirectory löschen
  9300.       { OS_error(); }
  9301.     end_system_call();
  9302.     #endif
  9303.     #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(WIN32_DOS) || defined(WIN32_UNIX)
  9304.     begin_system_call();
  9305.     if (rmdir(TheAsciz(pathstring))) # Unterdirectory löschen
  9306.       { OS_error(); }
  9307.     end_system_call();
  9308.     #endif
  9309.     #ifdef RISCOS
  9310.     begin_system_call();
  9311.     if (unlink(TheAsciz(pathstring))) # Unterdirectory löschen
  9312.       { OS_error(); }
  9313.     end_system_call();
  9314.     #endif
  9315.     value1 = T; mv_count=1; # 1 Wert T
  9316.   }
  9317.  
  9318. # UP: Initialisiert das Pathname-System.
  9319. # init_pathnames();
  9320. # kann GC auslösen
  9321.   global void init_pathnames (void);
  9322.   global void init_pathnames()
  9323.     {
  9324.       #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  9325.       { # Default-Drive initialisieren:
  9326.         var uintB drive = default_drive();
  9327.         O(default_drive) = make_string(&drive,1);
  9328.       }
  9329.       #endif
  9330.       # *DEFAULT-PATHNAME-DEFAULTS* initialisieren:
  9331.       recalc_defaults_pathname();
  9332.       #ifdef USER_HOMEDIR
  9333.       #if defined(UNIX) || defined(WIN32_UNIX)
  9334.       # Wir ziehen uns das Home-Directory und die benutzbare Shell aus dem
  9335.       # Environment. Es enthält (fast) immer mindestens folgende Variablen:
  9336.       #   LOGNAME = Username beim ersten Einloggen ("wahre" Identität des Benutzers)
  9337.       #   USER    = aktueller Username
  9338.       #   HOME    = aktuelles Home-Directory, aus /etc/passwd geholt
  9339.       #   SHELL   = aktuelle Standard-Shell, aus /etc/passwd geholt
  9340.       #   PATH    = Suchpfad bei Programmaufruf
  9341.       #   TERM    = Terminalemulation
  9342.       # Wir holen uns HOME (für "~" - Übersetzung) und SHELL (für EXECUTE).
  9343.       # Bei "~username" müssen wir das /etc/passwd - File absuchen.
  9344.       { # Im Environment nach Variable HOME suchen:
  9345.         begin_system_call();
  9346.        {var reg1 const char* homedir = getenv("HOME");
  9347.         end_system_call();
  9348.         if (!(homedir==NULL)) # gefunden?
  9349.           { O(user_homedir) = asciz_dir_to_pathname(homedir); } # ja -> eintragen
  9350.           else
  9351.           # nein -> Home-Directory aus dem Passwort-File holen:
  9352.           { # empfohlene Methode (siehe GETLOGIN(3V)): erst
  9353.             # getpwnam(getlogin()), dann getpwuid(getuid()) probieren.
  9354.             var reg2 const char* username;
  9355.             var reg1 struct passwd * userpasswd;
  9356.             begin_system_call();
  9357.             # 1. Versuch: getpwnam(getenv("USER"))
  9358.             username = getenv("USER"); # Username aus dem Environment holen
  9359.             if (!(username==NULL))
  9360.               { errno = 0; userpasswd = getpwnam(username); # passwd-Eintrag dazu
  9361.                 if (!(userpasswd==NULL)) goto userpasswd_ok; # gefunden -> ok
  9362.                 if (!(errno==0)) { OS_error(); } # Error melden
  9363.               }
  9364.             # 2. Versuch: getpwnam(getlogin())
  9365.             errno = 0; username = getlogin(); # Username aus /etc/utmp holen
  9366.             if (username==NULL)
  9367.               { if (!(errno==0)) { OS_error(); } } # Error melden
  9368.               else
  9369.               { errno = 0; userpasswd = getpwnam(username); # passwd-Eintrag dazu
  9370.                 if (!(userpasswd==NULL)) goto userpasswd_ok; # gefunden -> ok
  9371.                 if (!(errno==0)) { OS_error(); } # Error melden
  9372.               }
  9373.             # 3. Versuch: getpwuid(getuid())
  9374.             errno = 0; userpasswd = getpwuid(user_uid);
  9375.             if (!(userpasswd==NULL)) # gefunden?
  9376.               { userpasswd_ok:
  9377.                 end_system_call();
  9378.                 O(user_homedir) = asciz_dir_to_pathname(userpasswd->pw_dir); # ja -> Homedir als Pathname eintragen
  9379.               }
  9380.               else
  9381.               { if (!(errno==0)) { OS_error(); } # Error melden
  9382.                 end_system_call();
  9383.                 # nein -> aktuelles Directory nehmen:
  9384.                 O(user_homedir) = default_directory();
  9385.       }}  }   }
  9386.       #endif
  9387.       #endif
  9388.       #if defined(HAVE_SHELL) && !defined(AMIGAOS)
  9389.       #if defined(UNIX) || defined(WIN32_UNIX)
  9390.       # Die Kommando-Shell O(command_shell) bleibt unverändert, sonst
  9391.       # handelt man sich zu viele Portabilitätsprobleme ein.
  9392.       { # Im Environment nach Variable SHELL suchen:
  9393.         begin_system_call();
  9394.        {var reg1 const char* shell = getenv("SHELL");
  9395.         end_system_call();
  9396.         if (!(shell==NULL)) # gefunden?
  9397.           { O(user_shell) = asciz_to_string(shell); } # ja -> eintragen
  9398.           # sonst bleibt O(user_shell) auf dem Defaultwert "/bin/csh".
  9399.       }}
  9400.       #endif
  9401.       #ifdef MSDOS
  9402.       { # Im Environment nach Variable COMSPEC suchen:
  9403.         begin_system_call();
  9404.        {var reg1 const char* shell = getenv("COMSPEC");
  9405.         end_system_call();
  9406.         if (!(shell==NULL)) # gefunden?
  9407.           { O(command_shell) = asciz_to_string(shell); } # ja -> eintragen
  9408.           # sonst bleibt O(command_shell) auf dem Defaultwert "\\COMMAND.COM".
  9409.       }}
  9410.       #endif
  9411.       #endif
  9412.     }
  9413.  
  9414. #if defined(DJUNIX) || defined(WATCOM) || defined(EMUNIX_OLD_8d)
  9415. # UP: Legt Datum/Uhrzeit der Datei mit dem Handle handle im 4-Byte-Buffer ab.
  9416. # get_file_write_datetime(handle);
  9417. # > handle: Handle eines (offenen) Files
  9418. # < file_datetime: Datum und Uhrzeit der Datei
  9419.   local var struct { uintW time; uintW date; } file_datetime; # Buffer fürs Ergebnis
  9420.   local void get_file_write_datetime (uintW handle);
  9421.   #if defined(DJUNIX) || defined(WATCOM)
  9422.   #include <dos.h>
  9423.   local void get_file_write_datetime(handle)
  9424.     var reg1 uintW handle;
  9425.     {
  9426.      #ifndef GNU
  9427.       var union REGS in;
  9428.       var union REGS out;
  9429.       in.regB.ah = 0x57; in.regB.al = 0; # DOS Function 57H
  9430.       in.regW.bx = handle;
  9431.       intdos(&in,&out);
  9432.       file_datetime.time = out.regW.cx;
  9433.       file_datetime.date = out.regW.dx;
  9434.      #else # dasselbe, nur effizienter
  9435.       var uintW time;
  9436.       var uintW date;
  9437.       __asm__ (# DOS Function 57H
  9438.                " movw $0x5700,%%ax ; int $0x21 "
  9439.                : "=c" /* %cx */ (time), "=d" /* %dx */ (date)     # OUT
  9440.                :                                                  # IN
  9441.                : "ax","bx","si","di" /* %eax, %ebx, %esi, %edi */ # CLOBBER
  9442.               );
  9443.       file_datetime.time = time;
  9444.       file_datetime.date = date;
  9445.      #endif
  9446.     }
  9447.   #endif
  9448.   #ifdef EMUNIX_OLD_8d
  9449.   extern int __filetime ( /* int handle, int flag, struct _ftd * */ );
  9450.   #define get_file_write_datetime(handle)  __filetime(handle,0,&file_datetime)
  9451.   #endif
  9452. #endif
  9453. #ifdef AMIGAOS
  9454.   local var struct DateStamp file_datetime; # Buffer für Datum/Uhrzeit einer Datei
  9455. #endif
  9456. #if defined(UNIX) || defined(EMUNIX_NEW_8e) || defined(RISCOS) || defined(WIN32_DOS) || defined(WIN32_UNIX)
  9457.   local var time_t file_datetime; # Buffer für Datum/Uhrzeit einer Datei
  9458. #endif
  9459.  
  9460. LISPFUNN(file_write_date,1)
  9461. # (FILE-WRITE-DATE file), CLTL S. 424
  9462.   { var reg1 object pathname = popSTACK(); # pathname-Argument
  9463.     if (streamp(pathname))
  9464.       # Stream -> extra behandeln:
  9465.       { # muß File-Stream sein:
  9466.         pathname = as_file_stream(pathname);
  9467.         # Streamtyp File-Stream
  9468.        #if !defined(AMIGAOS)
  9469.         if ((TheStream(pathname)->strmflags & strmflags_open_B)
  9470.             && (!nullp(TheStream(pathname)->strm_file_handle))
  9471.            )
  9472.           # offener File-Stream
  9473.           { # direkt mit dem Handle arbeiten:
  9474.             #if defined(DJUNIX) || defined(WATCOM) || defined(EMUNIX_OLD_8d)
  9475.             begin_system_call();
  9476.             get_file_write_datetime(TheHandle(TheStream(pathname)->strm_file_handle));
  9477.             end_system_call();
  9478.             #endif
  9479.             #if defined(UNIX) || defined(EMUNIX_NEW_8e) || defined(RISCOS) || defined(WIN32_DOS) || defined(WIN32_UNIX)
  9480.             var struct stat status;
  9481.             begin_system_call();
  9482.             if (!( fstat(TheHandle(TheStream(pathname)->strm_file_handle),&status) ==0))
  9483.               { OS_error(); }
  9484.             end_system_call();
  9485.             file_datetime = status.st_mtime;
  9486.             #endif
  9487.           }
  9488.           else
  9489.        #endif
  9490.           # geschlossener File-Stream -> Truename als Pathname verwenden
  9491.           { pathname = TheStream(pathname)->strm_file_truename;
  9492.             goto is_pathname;
  9493.           }
  9494.       }
  9495.       else
  9496.       { pathname = coerce_pathname(pathname); # zu einem Pathname machen
  9497.         is_pathname: # pathname ist jetzt wirklich ein Pathname
  9498.         check_no_wildcards(pathname); # mit Wildcards -> Fehler
  9499.         pathname = use_default_dir(pathname); # Default-Directory einfügen
  9500.         if (namenullp(pathname)) { fehler_noname(pathname); } # Kein Name angegeben -> Fehler
  9501.         # Name angegeben.
  9502.         pushSTACK(pathname);
  9503.        {# Directory muß existieren:
  9504.         var reg3 object namestring = assure_dir_exists(FALSE); # Filename als ASCIZ-String
  9505.         #ifdef MSDOS
  9506.          #if defined(DJUNIX) || defined(WATCOM) || defined(EMUNIX_OLD_8d)
  9507.           # Datei öffnen:
  9508.           begin_system_call();
  9509.           { var reg2 sintW ergebnis = # Datei zu öffnen versuchen
  9510.               open(TheAsciz(namestring),O_RDONLY);
  9511.             if (ergebnis < 0) { OS_error(); } # Error melden
  9512.             # Nun enthält ergebnis das Handle des geöffneten Files.
  9513.             get_file_write_datetime(ergebnis); # Datum/Uhrzeit holen
  9514.             if (CLOSE(ergebnis) < 0) { OS_error(); } # Datei gleich wieder schließen
  9515.           }
  9516.           end_system_call();
  9517.          #else # defined(EMUNIX_NEW_8e)
  9518.           { var struct stat statbuf;
  9519.             begin_system_call();
  9520.             if (stat(TheAsciz(namestring),&statbuf) < 0) { OS_error(); }
  9521.             end_system_call();
  9522.             if (!S_ISREG(statbuf.st_mode)) { fehler_file_not_exists(); } # Datei muß existieren
  9523.             file_datetime = statbuf.st_mtime;
  9524.           }
  9525.          #endif
  9526.         #endif
  9527.         #ifdef AMIGAOS
  9528.         if (!file_exists(_EMA_)) { fehler_file_not_exists(); } # Datei muß existieren
  9529.         file_datetime = filestatus->fib_Date;
  9530.         #endif
  9531.         #if defined(UNIX) || defined(RISCOS) || defined(WIN32_UNIX)
  9532.         if (!file_exists(_EMA_)) { fehler_file_not_exists(); } # Datei muß existieren
  9533.         file_datetime = filestatus->st_mtime;
  9534.         #endif
  9535.         skipSTACK(1);
  9536.       }}
  9537.     # Datum/Uhrzeit steht nun im Buffer file_datetime.
  9538.     # In Decoded-Time-Format umwandeln:
  9539.     { var decoded_time timepoint;
  9540.       #if defined(DJUNIX) || defined(WATCOM) || defined(EMUNIX_OLD_8d)
  9541.       convert_timedate(file_datetime.time,file_datetime.date,&timepoint);
  9542.       #endif
  9543.       #if defined(UNIX) || defined(EMUNIX_NEW_8e) || defined(AMIGAOS) || defined(RISCOS) || defined(WIN32_DOS) || defined(WIN32_UNIX)
  9544.       convert_time(&file_datetime,&timepoint);
  9545.       #endif
  9546.       pushSTACK(timepoint.Sekunden);
  9547.       pushSTACK(timepoint.Minuten);
  9548.       pushSTACK(timepoint.Stunden);
  9549.       pushSTACK(timepoint.Tag);
  9550.       pushSTACK(timepoint.Monat);
  9551.       pushSTACK(timepoint.Jahr);
  9552.       funcall(S(encode_universal_time),6);
  9553.       # (ENCODE-UNIVERSAL-TIME Sekunden Minuten Stunden Tag Monat Jahr)
  9554.       # als Ergebnis
  9555.   } }
  9556.  
  9557. LISPFUNN(file_author,1)
  9558. # (FILE-AUTHOR file), CLTL S. 424
  9559.   { var reg1 object pathname = popSTACK(); # pathname-Argument
  9560.     if (streamp(pathname))
  9561.       # Stream -> extra behandeln:
  9562.       { # muß File-Stream sein:
  9563.         pathname = as_file_stream(pathname);
  9564.         # Streamtyp File-Stream
  9565.         if (TheStream(pathname)->strmflags & strmflags_open_B)
  9566.           # offener File-Stream -> OK
  9567.           {}
  9568.           else
  9569.           # geschlossener File-Stream -> Truename als Pathname verwenden
  9570.           { pathname = TheStream(pathname)->strm_file_truename;
  9571.             goto is_pathname;
  9572.           }
  9573.       }
  9574.       else
  9575.       { pathname = coerce_pathname(pathname); # zu einem Pathname machen
  9576.         is_pathname: # pathname ist jetzt wirklich ein Pathname
  9577.         # pathname ist jetzt ein Pathname.
  9578.         check_no_wildcards(pathname); # mit Wildcards -> Fehler
  9579.         pathname = use_default_dir(pathname); # Default-Directory einfügen
  9580.         if (namenullp(pathname)) { fehler_noname(pathname); } # Kein Name angegeben -> Fehler
  9581.         # Name angegeben.
  9582.         pushSTACK(pathname);
  9583.        {# Directory muß existieren:
  9584.         var reg3 object namestring = assure_dir_exists(FALSE); # Filename als ASCIZ-String
  9585.         #ifdef MSDOS
  9586.          #if 1
  9587.           # Datei öffnen:
  9588.           begin_system_call();
  9589.           { var reg2 sintW ergebnis = # Datei zu öffnen versuchen
  9590.               open(TheAsciz(namestring),O_RDONLY);
  9591.             if (ergebnis < 0) { OS_error(); } # Error melden
  9592.             # Nun enthält ergebnis das Handle des geöffneten Files.
  9593.             if (CLOSE(ergebnis) < 0) { OS_error(); } # Datei gleich wieder schließen
  9594.           }
  9595.           end_system_call();
  9596.          #else
  9597.           { var struct stat statbuf;
  9598.             begin_system_call();
  9599.             if (stat(TheAsciz(namestring),&statbuf) < 0) { OS_error(); }
  9600.             end_system_call();
  9601.             if (!S_ISREG(statbuf.st_mode)) { fehler_file_not_exists(); } # Datei muß existieren
  9602.           }
  9603.          #endif
  9604.         #endif
  9605.         #if defined(UNIX) || defined(AMIGAOS) || defined(RISCOS) || defined(WIN32_UNIX)
  9606.         if (!file_exists(_EMA_)) { fehler_file_not_exists(); } # Datei muß existieren
  9607.         #endif
  9608.         skipSTACK(1);
  9609.       }}
  9610.     # Datei existiert -> NIL als Wert
  9611.     value1 = NIL; mv_count=1;
  9612.   }
  9613.  
  9614. #if defined(UNIX) || defined(MSDOS) || defined(RISCOS) || defined(WIN32_UNIX)
  9615.  
  9616. LISPFUN(execute,1,0,rest,nokey,0,NIL)
  9617. # (EXECUTE file arg1 arg2 ...) ruft ein File mit gegebenen Argumenten auf.
  9618.   {var reg6 object* args_pointer = rest_args_pointer STACKop 1;
  9619.    {var reg1 object* argptr = args_pointer; # Pointer über die Argumente
  9620.     # File überprüfen:
  9621.     { var reg2 object* file_ = &NEXT(argptr);
  9622.       var reg3 object pathname = *file_;
  9623.       pathname = coerce_pathname(pathname); # zu einem Pathname machen
  9624.       check_no_wildcards(pathname); # mit Wildcards -> Fehler
  9625.       pathname = use_default_dir(pathname); # Default-Directory einfügen
  9626.       if (namenullp(pathname)) { fehler_noname(pathname); } # Kein Name angegeben -> Fehler
  9627.       # Name angegeben.
  9628.       pushSTACK(pathname);
  9629.      {# Directory muß existieren:
  9630.       var reg4 object namestring = assure_dir_exists(FALSE); # Filename als ASCIZ-String
  9631.       # Überprüfe, ob die Datei existiert:
  9632.       if_file_exists(namestring, ; , { fehler_file_not_exists(); } );
  9633.       *file_ = namestring; # retten
  9634.       skipSTACK(1);
  9635.     }}
  9636.     # restliche Argumente überprüfen:
  9637.     { var reg3 uintC count;
  9638.       dotimesC(count,argcount,
  9639.         { var reg2 object* arg_ = &NEXT(argptr);
  9640.           pushSTACK(*arg_); funcall(L(string),1); # nächstes Argument in String umwandeln
  9641.           *arg_ = string_to_asciz(value1); # und ASCIZ-String umwandeln
  9642.         });
  9643.    }}
  9644.    #if defined(EMUNIX_PORTABEL) || (defined(WATCOM) && defined(WINDOWS)) || defined(WIN32_DOS)
  9645.    # (Unter OS/2 scheint system() sicherer zu sein als spawnv(). Warum?)
  9646.    # Alle Argumente (nun ASCIZ-Strings) zusammenhängen, mit Spaces dazwischen:
  9647.    {var reg1 object* argptr = args_pointer; # Pointer über die Argumente
  9648.     var reg3 uintC count;
  9649.     dotimesC(count,argcount, # alle Argumente außer dem letzten durchlaufen
  9650.       { var reg2 object string = NEXT(argptr); # nächster Argumentstring
  9651.         TheSstring(string)->data[TheSstring(string)->length - 1] = ' ';
  9652.       });
  9653.    }
  9654.    { var reg2 object command = string_concat(1+argcount);
  9655.      # Programm aufrufen:
  9656.      begin_system_call();
  9657.     {var reg1 int ergebnis = system(TheAsciz(command));
  9658.      end_system_call();
  9659.      # Rückgabewert verwerten: =0 (OK) -> T, >0 (nicht OK) -> NIL :
  9660.      value1 = (ergebnis==0 ? T : NIL); mv_count=1;
  9661.    }}
  9662.    #endif
  9663.    #if defined(DJUNIX) || (defined(EMUNIX) && !defined(EMUNIX_PORTABEL)) || (defined(WATCOM) && !defined(WINDOWS))
  9664.    {# argv-Array aufbauen:
  9665.     var DYNAMIC_ARRAY(reg5,argv,char*,1+(uintL)argcount+1);
  9666.     { var reg1 object* argptr = args_pointer;
  9667.       var reg2 char** argvptr = &argv[0];
  9668.       var reg4 uintC count;
  9669.       dotimespC(count,argcount+1,
  9670.         { var reg3 object arg = NEXT(argptr); # nächstes Argument, ASCIZ-String
  9671.           *argvptr++ = TheAsciz(arg); # in argv einfüllen
  9672.         });
  9673.       *argvptr = NULL; # und mit Nullpointer abschließen
  9674.     }
  9675.     # Programm aufrufen:
  9676.     begin_system_call();
  9677.     {var reg2 int flags =
  9678.        #ifdef EMUNIX_NEW_9a
  9679.          P_QUOTE  # Argumente korrekt quoten
  9680.        #else
  9681.          0
  9682.        #endif
  9683.        ;
  9684.      var reg1 int ergebnis = spawnv(P_WAIT|flags,argv[0],argv);
  9685.      end_system_call();
  9686.      if (ergebnis < 0) { OS_error(); } # Error melden
  9687.      # Fertig.
  9688.      set_args_end_pointer(args_pointer); # STACK aufräumen
  9689.      # Rückgabewert verwerten: =0 (OK) -> T, >0 (nicht OK) -> NIL :
  9690.      value1 = (ergebnis==0 ? T : NIL); mv_count=1;
  9691.     }
  9692.     FREE_DYNAMIC_ARRAY(argv);
  9693.    }
  9694.    #endif
  9695.    #if defined(UNIX) || defined(RISCOS) || defined(WIN32_UNIX)
  9696.    { # argv-Array im Stack aufbauen und Strings in den Stack kopieren:
  9697.      var reg9 uintL argvdata_length = 0;
  9698.      { var reg1 object* argptr = args_pointer;
  9699.        var reg3 uintC count;
  9700.        dotimespC(count,argcount+1,
  9701.          { var reg2 object arg = NEXT(argptr); # nächstes Argument, ASCIZ-String
  9702.            argvdata_length += TheSstring(arg)->length;
  9703.          });
  9704.      }
  9705.     {var DYNAMIC_ARRAY(reg9,argv,char*,1+(uintL)argcount+1);
  9706.      var DYNAMIC_ARRAY(reg9,argvdata,char,argvdata_length);
  9707.      { var reg8 object* argptr = args_pointer;
  9708.        var reg7 char** argvptr = &argv[0];
  9709.        var reg1 char* argvdataptr = &argvdata[0];
  9710.        var reg5 uintC count;
  9711.        dotimespC(count,argcount+1,
  9712.          { var reg4 object arg = NEXT(argptr); # nächstes Argument, ASCIZ-String
  9713.            var reg2 char* ptr = TheAsciz(arg);
  9714.            var reg3 uintL len = TheSstring(arg)->length;
  9715.            *argvptr++ = argvdataptr; # in argv einfüllen
  9716.            dotimespL(len,len, { *argvdataptr++ = *ptr++; } ); # und kopieren
  9717.          });
  9718.        *argvptr = NULL; # und mit Nullpointer abschließen
  9719.      }
  9720.      # einen neuen Prozeß starten:
  9721.      { var reg2 int child;
  9722.        begin_system_call();
  9723.        begin_want_sigcld();
  9724.        if ((child = vfork()) ==0)
  9725.          # Dieses Programmstück wird vom Child-Prozeß ausgeführt:
  9726.          { execv(argv[0],argv); # Programm aufrufen
  9727.            _exit(-1); # sollte dies mißlingen, Child-Prozeß beenden
  9728.          }
  9729.        # Dieses Programmstück wird wieder vom Aufrufer ausgeführt:
  9730.        if (child==-1)
  9731.          # Etwas ist mißlungen, entweder beim vfork oder beim execv.
  9732.          # In beiden Fällen wurde errno gesetzt.
  9733.          { end_want_sigcld(); OS_error(); }
  9734.        # Warten, bis der Child-Prozeß beendet wird:
  9735.       {var int status = wait2(child);
  9736.        # vgl. WAIT(2V) und #include <sys/wait.h> :
  9737.        #   WIFSTOPPED(status)  ==  ((status & 0xFF) == 0177)
  9738.        #   WEXITSTATUS(status)  == ((status & 0xFF00) >> 8)
  9739.        end_want_sigcld();
  9740.        end_system_call();
  9741.        # Fertig.
  9742.        set_args_end_pointer(args_pointer); # STACK aufräumen
  9743.        value1 = (((status & 0xFF) == 0000) # Prozeß normal beendet (ohne Signal, ohne Core-Dump) ?
  9744.                  ? # ja -> Exit-Status als Wert:
  9745.                    fixnum( (status & 0xFF00) >> 8)
  9746.                  : NIL # nein -> NIL als Wert
  9747.                 );
  9748.        mv_count=1;
  9749.      }}
  9750.      FREE_DYNAMIC_ARRAY(argvdata);
  9751.      FREE_DYNAMIC_ARRAY(argv);
  9752.    }}
  9753.    #endif
  9754.   }
  9755.  
  9756. #endif
  9757.  
  9758. #ifdef AMIGAOS
  9759.  
  9760. LISPFUN(execute,1,0,norest,nokey,0,NIL)
  9761. # (EXECUTE command-string) schickt einen String an das Betriebssystem.
  9762. # Das ist in diesem Fall mit (SHELL command-string) synonym.
  9763.   { C_shell(); } # SHELL aufrufen, selber Stackaufbau
  9764.  
  9765. #endif
  9766.  
  9767. #ifdef HAVE_SHELL
  9768.  
  9769. # (SHELL) ruft eine Shell auf.
  9770. # (SHELL command) ruft eine Shell auf und läßt sie ein Kommando ausführen.
  9771.  
  9772. #if defined(AMIGAOS)
  9773.  
  9774. LISPFUN(shell,0,1,norest,nokey,0,NIL)
  9775.   { var reg1 object command = popSTACK();
  9776.     if (eq(command,unbound))
  9777.       # Kommandointerpreter aufrufen:
  9778.       { run_time_stop();
  9779.         begin_system_call();
  9780.        {var reg2 BOOL ergebnis = FALSE;
  9781.         #if 0 # so einfach geht's wohl nicht
  9782.         ergebnis = Execute("",Input_handle,Output_handle);
  9783.         #else
  9784.         var reg3 Handle terminal = Open("*",MODE_READWRITE);
  9785.         if (!(terminal==Handle_NULL))
  9786.           { ergebnis = Execute("",terminal,Handle_NULL);
  9787.             Close(terminal);
  9788.             Write(Output_handle,CRLFstring,1);
  9789.           }
  9790.         #endif
  9791.         end_system_call();
  9792.         run_time_restart();
  9793.         # Rückgabewert verwerten: ausgeführt -> T, nicht gefunden -> NIL :
  9794.         value1 = (ergebnis ? T : NIL); mv_count=1;
  9795.       }}
  9796.       else
  9797.       # einzelnes Kommando ausführen:
  9798.       { if (!stringp(command))
  9799.           { pushSTACK(command); # Wert für Slot DATUM von TYPE-ERROR
  9800.             pushSTACK(S(string)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  9801.             pushSTACK(command);
  9802.             pushSTACK(TheSubr(subr_self)->name);
  9803.             //: DEUTSCH "~: Befehl muß ein String sein, nicht ~."
  9804.             //: ENGLISH "~: the command should be a string, not ~"
  9805.             //: FRANCAIS "~ : La commande doit être de type STRING et non ~."
  9806.             fehler(type_error, GETTEXT("~: the command should be a string, not ~"));
  9807.           }
  9808.         command = string_to_asciz(command); # in Simple-String umwandeln
  9809.         # Kommando ausführen:
  9810.         run_time_stop();
  9811.         begin_system_call();
  9812.        {var reg2 BOOL ergebnis = Execute(TheAsciz(command),Handle_NULL,Output_handle);
  9813.         end_system_call();
  9814.         run_time_restart();
  9815.         # Rückgabewert verwerten: ausgeführt -> T, nicht gefunden -> NIL :
  9816.         value1 = (ergebnis ? T : NIL); mv_count=1;
  9817.       }}
  9818.   }
  9819.  
  9820. #else # UNIX || MSDOS || ...
  9821.  
  9822. LISPFUN(shell,0,1,norest,nokey,0,NIL)
  9823.   { var reg1 object command = popSTACK();
  9824.     if (eq(command,unbound))
  9825.       { # (EXECUTE shell) ausführen:
  9826.         #if defined(UNIX) || defined(WIN32_UNIX)
  9827.         pushSTACK(O(user_shell)); # Shell-Name
  9828.         #else # MSDOS
  9829.         pushSTACK(O(command_shell)); # Shell-Name
  9830.         #endif
  9831.         funcall(L(execute),1);
  9832.       }
  9833.       else
  9834.       #if defined(MSDOS) || defined(RISCOS)
  9835.       # Dem DOS-Kommandointerpreter muß man das Kommando bereits entlang
  9836.       # der Leerstellen in einzelne Teile zerlegt übergeben. Die Funktion
  9837.       # system() erledigt uns das zum Glück.
  9838.       { command = string_to_asciz(command);
  9839.         begin_system_call();
  9840.         # Programm aufrufen:
  9841.        {var reg1 int ergebnis = system(TheAsciz(command));
  9842.         end_system_call();
  9843.         # Rückgabewert verwerten: =0 (OK) -> T, >0 (nicht OK) -> NIL :
  9844.         value1 = (ergebnis==0 ? T : NIL); mv_count=1;
  9845.       }}
  9846.       #else
  9847.       { # (EXECUTE shell "-c" command) ausführen:
  9848.         pushSTACK(O(command_shell)); # Shell-Name
  9849.         pushSTACK(O(command_shell_option)); # Shell-Option "-c"
  9850.         #if defined(MSDOS) && defined(EMUNIX)
  9851.         # Unter DOS 2.x, 3.x kann das Optionen-Zeichen ein anderes sein!
  9852.         if ((_osmode == DOS_MODE) && (_osmajor < 4))
  9853.           { var reg2 uintB swchar = _swchar();
  9854.             if (swchar) # evtl. "/C" durch etwas anderes ersetzen
  9855.               { TheSstring(STACK_0)->data[0] = swchar; } # (destruktiv)
  9856.           }
  9857.         #endif
  9858.         pushSTACK(command);
  9859.         funcall(L(execute),3);
  9860.       }
  9861.       #endif
  9862.   }
  9863.  
  9864. #endif
  9865.  
  9866. #endif
  9867.  
  9868. LISPFUNN(savemem,1)
  9869. # (SAVEMEM pathname) speichert ein Speicherabbild unter pathname ab.
  9870.   { # (OPEN pathname :direction :output) ausführen:
  9871.     # pathname als 1. Argument
  9872.     pushSTACK(S(Kdirection)); # :DIRECTION als 2. Argument
  9873.     pushSTACK(S(Koutput)); # :OUTPUT als 3. Argument
  9874.     #if !(defined(UNIX) || defined(WIN32_UNIX))
  9875.     funcall(L(open),3);
  9876.     #else
  9877.     # Unter Unix mit mmap() darf man existierende .mem-Files nicht einfach
  9878.     # überschreiben, weil laufende Lisp-Prozesse dadurch abstürzen würden.
  9879.     pushSTACK(S(Kif_exists)); # :IF-EXISTS als 4. Argument
  9880.     pushSTACK(S(Krename_and_delete)); # :RENAME-AND-DELETE als 5. Argument
  9881.     funcall(L(open),5);
  9882.     #endif
  9883.     # Speicherabbild in die Datei schreiben:
  9884.     # (Den Stream muß die Funktion savemem() schließen, auch im Fehlerfalle.)
  9885.     savemem(value1);
  9886.     value1 = T; mv_count=1; # 1 Wert T
  9887.   }
  9888.  
  9889. # ==============================================================================
  9890.  
  9891. #ifdef HAVE_DISASSEMBLER
  9892.  
  9893. # Finding the full path of the executable.
  9894. # Bruno Haible 20.12.1994
  9895.  
  9896. # This assumes that the executable is not removed or renamed while running.
  9897.  
  9898. # file name of the executable
  9899. local char* executable_name = NULL;
  9900. #define default_executable_name  "lisp.run"
  9901.  
  9902. # file descriptor of the executable
  9903. # (Only used to verify that we find the correct executable.)
  9904. local int executable_fd = -1;
  9905.  
  9906. # maybe_executable(pathname)
  9907. # checks whether a given pathname may belong to the executable.
  9908. local boolean maybe_executable (const char * filename);
  9909. local boolean maybe_executable(filename)
  9910.   var reg1 const char * filename;
  9911. { var struct stat statexe;
  9912.   var struct stat statfile;
  9913.   if (access(filename,R_OK|X_OK) < 0)
  9914.     return FALSE;
  9915.   if (executable_fd < 0)
  9916.     return TRUE;
  9917.   # If we already have an executable_fd, check that filename points to
  9918.   # the same inode.
  9919.   if (fstat(executable_fd,&statexe) < 0)
  9920.     return TRUE;
  9921.   if (stat(filename,&statfile) < 0)
  9922.     return FALSE;
  9923.   if (statfile.st_dev
  9924.       && statfile.st_dev == statexe.st_dev
  9925.       && statfile.st_ino == statexe.st_ino
  9926.      )
  9927.     return TRUE;
  9928.   return FALSE;
  9929. }
  9930.  
  9931. # find_executable(program_name)
  9932. # is to be called immediately after the program starts,
  9933. # with program_name = argv[0],
  9934. # before any chdir() operation and before any setenv("PATH",...).
  9935. # It determines the full program path and opens a file descriptor to
  9936. # the executable, for later use.
  9937. # Return value is 0 if successful, -1 and errno set if not.
  9938. global int find_executable (const char * program_name);
  9939. global int find_executable(program_name)
  9940.   var reg3 const char * program_name;
  9941. { # Don't need to execute this more than once.
  9942.   if (!(executable_name == NULL)) return 0;
  9943.   #ifdef UNIX_LINUX
  9944.   # The executable is accessible as /proc/<pid>/exe. We try this first
  9945.   # because it is safer: no race condition w.r.t. the file system. It may
  9946.   # fail, however, if the user has not compiled /proc support into his
  9947.   # kernel.
  9948.   { var char buf[6+10+5];
  9949.     var reg1 int fd;
  9950.     sprintf(buf,"/proc/%d/exe",getpid());
  9951.     fd = OPEN(buf,O_RDONLY,my_open_mask);
  9952.     if (fd >= 0)
  9953.       executable_fd = fd;
  9954.   }
  9955.   #endif
  9956.   # Now we guess the executable's full path. We assume the executable
  9957.   # has been called via execlp() or execvp() with properly set up argv[0].
  9958.   # The login(1) convention to add a '-' prefix to argv[0] is not supported.
  9959.  {var reg8 boolean has_slash = FALSE;
  9960.   {var reg1 const char * p;
  9961.    for (p = program_name; *p; p++) { if (*p == '/') { has_slash = TRUE; break; } }
  9962.   }
  9963.   if (!has_slash)
  9964.     { # exec searches paths without slashes in the directory list given
  9965.       # by $PATH.
  9966.       var reg7 const char * path = getenv("PATH");
  9967.       if (!(path==NULL))
  9968.         { var reg1 const char * p;
  9969.           var reg6 const char * p_next;
  9970.           for (p = path; *p; p = p_next)
  9971.             { var reg2 const char * q;
  9972.               var reg4 uintL p_len;
  9973.               for (q = p; *q; q++) { if (*q == ':') break; }
  9974.               p_len = q-p; p_next = (*q=='\0' ? q : q+1);
  9975.               # We have a path item at p, of length p_len.
  9976.               # Now concatenate the path item and program_name.
  9977.              {var reg5 char * concat_name = (char*) malloc(p_len + strlen(program_name) + 2);
  9978.               if (concat_name == NULL) { errno = ENOMEM; goto notfound; }
  9979.               if (p_len == 0)
  9980.                 # empty PATH element designates the current directory
  9981.                 { strcpy(concat_name,program_name); }
  9982.                 else
  9983.                 { memcpy(concat_name, p, p_len);
  9984.                   sprintf(concat_name+p_len, "/%s", program_name);
  9985.                 }
  9986.               if (maybe_executable(concat_name))
  9987.                 # Assume we have found the executable
  9988.                 { program_name = concat_name; goto resolve; }
  9989.               free(concat_name);
  9990.             }}
  9991.         }
  9992.       # Not found in the PATH, assume the current directory.
  9993.     }
  9994.   # exec treats paths containing slashes as relative to the current directory.
  9995.   if (maybe_executable(program_name))
  9996.     resolve:
  9997.     # resolve program_name:
  9998.     { executable_name = (char*) malloc(MAXPATHLEN);
  9999.       if (executable_name == NULL) { errno = ENOMEM; goto notfound; }
  10000.       if (realpath(program_name,executable_name) == NULL)
  10001.         { free(executable_name); goto notfound; }
  10002.       return 0;
  10003.     }
  10004.   errno = ENOENT;
  10005.  notfound:
  10006.   executable_name = default_executable_name; return -1;
  10007. }}
  10008.  
  10009. # (SYS::PROGRAM-NAME) returns the executable's name.
  10010. LISPFUNN(program_name,0)
  10011. { value1 = asciz_to_string(executable_name); mv_count=1; }
  10012.  
  10013. #endif
  10014.  
  10015. # ==============================================================================
  10016.  
  10017. #ifdef EMUNIX_PORTABEL
  10018.  
  10019. # Umgehen eines lästigen ENAMETOOLONG Errors bei Benutzung von langen
  10020. # Filenamen auf FAT-Drives unter OS/2:
  10021.  
  10022. #undef chdir
  10023. #undef access
  10024. #undef stat
  10025. #undef unlink
  10026. #undef rename
  10027. #undef __findfirst
  10028. #undef mkdir
  10029. #undef open
  10030. #undef creat
  10031. #undef spawnv
  10032.  
  10033. # path2 := verkürzte Kopie von path1
  10034. local void shorten_path (const char* path1, char* path2)
  10035.   { var reg1 const uintB* p1 = path1;
  10036.     var reg2 uintB* p2 = path2;
  10037.     var reg3 uintB c;
  10038.     var reg4 uintC wordlength = 0; # bisherige Länge in Name oder Typ
  10039.     var reg5 uintC maxwordlength = 8; # = 8 im Namen, = 3 im Typ
  10040.     loop
  10041.       { c = *p1++;
  10042.         if (c=='\0') { *p2++ = c; break; }
  10043.         if ((c=='\\') || (c=='/') || (c==':'))
  10044.           { *p2++ = c; wordlength = 0; maxwordlength = 8; }
  10045.         elif (c=='.')
  10046.           { *p2++ = c; wordlength = 0; maxwordlength = 3; }
  10047.         else
  10048.           { if (++wordlength <= maxwordlength) { *p2++ = c; } }
  10049.   }   }
  10050.  
  10051. global int my_chdir(path)
  10052.   var reg2 CONST char* path;
  10053.   { var reg1 int erg = chdir(path);
  10054.     if ((erg<0) && (errno==ENAMETOOLONG))
  10055.       { var reg3 char* shorter_path = alloca(asciz_length(path)+1);
  10056.         shorten_path(path,shorter_path);
  10057.         erg = chdir(shorter_path);
  10058.       }
  10059.     return erg;
  10060.   }
  10061.  
  10062. global int my_access(path,amode)
  10063.   var reg3 CONST char* path;
  10064.   var reg2 int amode;
  10065.   { var reg1 int erg = access(path,amode);
  10066.     if ((erg<0) && (errno==ENAMETOOLONG))
  10067.       { var reg4 char* shorter_path = alloca(asciz_length(path)+1);
  10068.         shorten_path(path,shorter_path);
  10069.         erg = access(shorter_path,amode);
  10070.       }
  10071.     return erg;
  10072.   }
  10073.  
  10074. global int my_stat(path,buf)
  10075.   var reg3 CONST char* path;
  10076.   var reg2 struct stat * buf;
  10077.   { var reg1 int erg = stat(path,buf);
  10078.     if ((erg<0) && (errno==ENAMETOOLONG))
  10079.       { var reg4 char* shorter_path = alloca(asciz_length(path)+1);
  10080.         shorten_path(path,shorter_path);
  10081.         erg = stat(shorter_path,buf);
  10082.       }
  10083.     return erg;
  10084.   }
  10085.  
  10086. global int my_unlink(path)
  10087.   var reg2 CONST char* path;
  10088.   { var reg1 int erg = unlink(path);
  10089.     if ((erg<0) && (errno==ENAMETOOLONG))
  10090.       { var reg3 char* shorter_path = alloca(asciz_length(path)+1);
  10091.         shorten_path(path,shorter_path);
  10092.         erg = unlink(shorter_path);
  10093.       }
  10094.     return erg;
  10095.   }
  10096.  
  10097. global int my_rename(oldpath,newpath)
  10098.   var reg3 CONST char* oldpath;
  10099.   var reg2 CONST char* newpath;
  10100.   { var reg1 int erg = rename(oldpath,newpath);
  10101.     if ((erg<0) && (errno==ENAMETOOLONG))
  10102.       { var reg4 char* shorter_oldpath = alloca(asciz_length(oldpath)+1);
  10103.         shorten_path(oldpath,shorter_oldpath);
  10104.         erg = rename(shorter_oldpath,newpath);
  10105.         if ((erg<0) && (errno==ENAMETOOLONG))
  10106.           { var reg5 char* shorter_newpath = alloca(asciz_length(newpath)+1);
  10107.             shorten_path(newpath,shorter_newpath);
  10108.             erg = rename(shorter_oldpath,shorter_newpath);
  10109.       }   }
  10110.     return erg;
  10111.   }
  10112.  
  10113. global int my___findfirst(path,attrib,ffblk)
  10114.   var reg4 const char* path;
  10115.   var reg2 int attrib;
  10116.   var reg3 struct ffblk * ffblk;
  10117.   { var reg1 int erg = __findfirst(path,attrib,ffblk);
  10118.     if ((erg<0) && (errno==ENAMETOOLONG))
  10119.       { var reg5 char* shorter_path = alloca(asciz_length(path)+1);
  10120.         shorten_path(path,shorter_path);
  10121.         erg = __findfirst(shorter_path,attrib,ffblk);
  10122.       }
  10123.     return erg;
  10124.   }
  10125.  
  10126. #ifdef EMUNIX_OLD_8e
  10127.   #define mkdir(path,attrib) (mkdir)(path)
  10128. #endif
  10129. global int my_mkdir(path,attrib)
  10130.   var reg2 CONST char* path;
  10131.   var reg3 long attrib;
  10132.   { var reg1 int erg = mkdir(path,attrib);
  10133.     if ((erg<0) && (errno==ENAMETOOLONG))
  10134.       { var reg4 char* shorter_path = alloca(asciz_length(path)+1);
  10135.         shorten_path(path,shorter_path);
  10136.         erg = mkdir(shorter_path,attrib);
  10137.       }
  10138.     return erg;
  10139.   }
  10140.  
  10141. global int my_open(path,flags)
  10142.   var reg3 CONST char* path;
  10143.   var reg2 int flags;
  10144.   { var reg1 int erg = open(path,flags);
  10145.     if ((erg<0) && (errno==ENAMETOOLONG))
  10146.       { var reg4 char* shorter_path = alloca(asciz_length(path)+1);
  10147.         shorten_path(path,shorter_path);
  10148.         erg = open(shorter_path,flags);
  10149.       }
  10150.     return erg;
  10151.   }
  10152.  
  10153. #define creat(path,mode)  open(path,O_RDWR|O_TRUNC|O_CREAT,mode)
  10154. global int my_creat(path,pmode)
  10155.   var reg3 CONST char* path;
  10156.   var reg2 int pmode;
  10157.   { var reg1 int erg = creat(path,pmode);
  10158.     if ((erg<0) && (errno==ENAMETOOLONG))
  10159.       { var reg4 char* shorter_path = alloca(asciz_length(path)+1);
  10160.         shorten_path(path,shorter_path);
  10161.         erg = creat(shorter_path,pmode);
  10162.       }
  10163.     return erg;
  10164.   }
  10165.  
  10166. global int my_spawnv(pmode,path,argv)
  10167.   var reg2 int pmode;
  10168.   var reg4 CONST char* path;
  10169.   var reg3 CONST char* CONST * argv;
  10170.   { var reg1 int erg = spawnv(pmode,path,argv);
  10171.     if ((erg<0) && (errno==ENAMETOOLONG))
  10172.       { var reg5 char* shorter_path = alloca(asciz_length(path)+1);
  10173.         shorten_path(path,shorter_path);
  10174.         erg = spawnv(pmode,shorter_path,argv);
  10175.       }
  10176.     return erg;
  10177.   }
  10178.  
  10179. #endif
  10180.  
  10181. #if DJGPP == 2
  10182. # hack until DJGPP2 gets fixed 
  10183. # (symptom: EACCES on read of just-recreated files)
  10184. global int djgpp2_creat (CONST char *path, unsigned long mode);
  10185. global int djgpp2_creat(path,mode)
  10186.   var reg3 CONST char* path;
  10187.   var reg2 unsigned long mode;
  10188.   {
  10189.     if (unlink(path) < 0) { OS_error(); }
  10190.     #undef creat
  10191.     return creat(path,mode);
  10192.   }
  10193. #endif
  10194.  
  10195. # ==============================================================================
  10196.  
  10197.