home *** CD-ROM | disk | FTP | other *** search
/ Il CD di internet / CD.iso / SOURCE / D / CLISP / CLISPSRC.TAR / clisp-1995-01-01 / src / pathname.d < prev    next >
Encoding:
Text File  |  1994-12-31  |  469.6 KB  |  10,816 lines
  1. # Pathnames fⁿr CLISP
  2. # Bruno Haible 31.12.1994
  3. # Logical Pathnames: Marcus Daniels 16.9.1994
  4.  
  5. #include "lispbibl.c"
  6.  
  7.  
  8. #ifdef UNIX
  9.   # Library-Funktion realpath implementieren:
  10.   # [Copyright: SUN Microsystems, B. Haible]
  11.   # TITLE
  12.   #   REALPATH(3)
  13.   # SYNOPSIS
  14.   #   char* realpath (char* path, char resolved_path[MAXPATHLEN]);
  15.   # DESCRIPTION
  16.   #   realpath() expands all symbolic links  and  resolves  refer-
  17.   #   ences  to '/./', '/../' and extra '/' characters in the null
  18.   #   terminated string named by path and stores the canonicalized
  19.   #   absolute pathname in the buffer named by resolved_path.  The
  20.   #   resulting path will have no symbolic links  components,  nor
  21.   #   any '/./' or '/../' components.
  22.   # RETURN VALUES
  23.   #   realpath() returns a pointer to the  resolved_path  on  suc-
  24.   #   cess.   On  failure, it returns NULL, sets errno to indicate
  25.   #   the error, and places in resolved_path the absolute pathname
  26.   #   of the path component which could not be resolved.
  27.   #define realpath  my_realpath  # Consensys deklariert realpath() bereits...
  28.   local char* realpath (char* path, char* resolved_path);
  29.   # Methode: benutze getwd und readlink.
  30.   local char* realpath(path,resolved_path)
  31.     char* path;
  32.     char* resolved_path;
  33.     { char mypath[MAXPATHLEN];
  34.       int symlinkcount = 0; # Anzahl bisher aufgetretener symbolischer Links
  35.       char* resolved_limit = &resolved_path[MAXPATHLEN-1];
  36.       # Gⁿltige Pointer sind die mit resolved_path <= ptr <= resolved_limit.
  37.       # In *resolved_limit darf h÷chstens noch ein Nullbyte stehen.
  38.       # (Analog mit mypath.)
  39.       char* resolve_start;
  40.       { char* resolved_ptr = resolved_path; # (bleibt stets <= resolved_limit)
  41.         # evtl. Working-Directory benutzen:
  42.         if (!(path[0]=='/')) # kein absoluter Pathname ?
  43.           { if (getwd(resolved_path) == NULL) { return NULL; }
  44.             resolved_ptr = resolved_path;
  45.             while (*resolved_ptr) { resolved_ptr++; }
  46.             if (resolved_ptr < resolved_limit) { *resolved_ptr++ = '/'; }
  47.             resolve_start = resolved_ptr;
  48.           }
  49.           else
  50.           { resolve_start = resolved_ptr = &resolved_path[0]; }
  51.         # Dann path selber einkopieren:
  52.        {char* path_ptr = path;
  53.         while ((resolved_ptr < resolved_limit) && *path_ptr)
  54.           { *resolved_ptr++ = *path_ptr++; }
  55.         # Mit '/' und einem Nullbyte abschlie▀en:
  56.         if (resolved_ptr < resolved_limit) { *resolved_ptr++ = '/'; }
  57.         *resolved_ptr = 0;
  58.       }}
  59.       # Los geht's nun in resolved_path ab resolve_start.
  60.       { char* from_ptr = resolve_start;
  61.         char* to_ptr = resolve_start;
  62.         while ((to_ptr < resolved_limit) && (*from_ptr))
  63.           # Bis hierher hat der Pfad in  resolved_path[0]...to_ptr[-1]
  64.           # die Gestalt '/subdir1/subdir2/.../txt',
  65.           # wobei 'txt' evtl. leer, aber kein subdir leer.
  66.           { char next = *from_ptr++; *to_ptr++ = next;
  67.             if ((next == '/') && (to_ptr > resolved_path+1))
  68.               # to_ptr[-1]='/'  ->  Directory ...to_ptr[-2] aufl÷sen:
  69.               { char* last_subdir_end = &to_ptr[-2];
  70.                 switch (*last_subdir_end)
  71.                   { case '/':
  72.                       # '//' wird zu '/' vereinfacht:
  73.                       to_ptr--;
  74.                       break;
  75.                     case '.':
  76.                       { char* last_subdir_ptr = &last_subdir_end[-1];
  77.                         switch (*last_subdir_ptr)
  78.                           { case '.':
  79.                               if (*--last_subdir_ptr == '/')
  80.                                 # letztes subdir war '/../'
  81.                                 # Dafⁿr das subdir davor entfernen:
  82.                                 { while ((last_subdir_ptr > resolved_path) && !(*--last_subdir_ptr == '/'));
  83.                                   to_ptr = last_subdir_ptr+1;
  84.                                 }
  85.                               break;
  86.                             case '/':
  87.                               # letztes subdir war '/./'
  88.                               # entfernen:
  89.                               to_ptr = last_subdir_end;
  90.                               break;
  91.                       }   }
  92.                       break;
  93.                     default:
  94.                       # nach einem normalen subdir
  95.                       #ifdef HAVE_READLINK
  96.                       # symbolischen Link lesen:
  97.                       to_ptr[-1]=0; # '/' durch 0 ersetzen
  98.                       { int linklen = readlink(resolved_path,mypath,sizeof(mypath)-1);
  99.                         if (linklen >=0)
  100.                           # war ein symbolisches Link
  101.                           { if (++symlinkcount > MAXSYMLINKS) { errno = ELOOP_VALUE; return NULL; }
  102.                             # noch aufzul÷senden path-Anteil an den Link-Inhalt anhΣngen:
  103.                             { char* mypath_ptr = &mypath[linklen]; # ab hier ist Platz
  104.                               char* mypath_limit = &mypath[MAXPATHLEN-1]; # bis hierher
  105.                               if (mypath_ptr < mypath_limit) { *mypath_ptr++ = '/'; } # erst ein '/' anhΣngen
  106.                               # dann den Rest:
  107.                               while ((mypath_ptr <= mypath_limit) && (*mypath_ptr = *from_ptr++)) { mypath_ptr++; }
  108.                               *mypath_ptr = 0; # und mit 0 abschlie▀en
  109.                             }
  110.                             # Dies ersetzt bzw. ergΣnzt den path:
  111.                             if (mypath[0] == '/')
  112.                               # ersetzt den path:
  113.                               { from_ptr = &mypath[0]; to_ptr = resolved_path;
  114.                                 while (*to_ptr++ = *from_ptr++);
  115.                                 from_ptr = resolved_path;
  116.                               }
  117.                               else
  118.                               # ergΣnzt den path:
  119.                               { # Linknamen streichen. Dazu bis zum letzten '/' suchen:
  120.                                 { char* ptr = &to_ptr[-1];
  121.                                   while ((ptr > resolved_path) && !(*--ptr == '/'));
  122.                                   from_ptr = &ptr[1];
  123.                                 }
  124.                                 { char* mypath_ptr = &mypath[0]; to_ptr = from_ptr;
  125.                                   while ((to_ptr <= resolved_limit) && (*to_ptr++ = *mypath_ptr++));
  126.                               } }
  127.                             to_ptr = from_ptr;
  128.                           }
  129.                           else
  130.                           #if defined(UNIX_IRIX)
  131.                           if ((errno == EINVAL) || (errno == ENXIO))
  132.                           #elif defined(UNIX_MINT)
  133.                           if ((errno == EINVAL) || (errno == EACCESS))
  134.                           #else
  135.                           if (errno == EINVAL)
  136.                           #endif
  137.                             # kein symbolisches Link
  138.                             { to_ptr[-1] = '/'; } # wieder den '/' eintragen
  139.                           else
  140.                             { return NULL; } # Fehler
  141.                       }
  142.                       #endif
  143.                       break;
  144.               }   }
  145.           } # dann zum nΣchsten subdir
  146.         # ein '/' am Ende streichen:
  147.         if ((to_ptr[-1] == '/') && (to_ptr > resolved_path+1)) { to_ptr--; }
  148.         to_ptr[0] = 0; # durch 0 abschlie▀en
  149.         return resolved_path; # fertig
  150.     } }
  151. #endif
  152. #ifdef RISCOS
  153.   # SYNOPSIS
  154.   #   char* realpath (char* path, char resolved_path[MAXPATHLEN]);
  155.   # RETURN VALUES
  156.   #   realpath() returns a pointer to the resolved_path on success.
  157.   #   On failure, it returns NULL and sets errno to indicate the error.
  158.   local char* realpath (char* path, char* resolved_path);
  159.   #include <sys/os.h>
  160.   local char* realpath(path,resolved_path)
  161.     var char* path;
  162.     var char* resolved_path;
  163.     { var int handle;
  164.       var int r[10];
  165.       #if 0 # Both of these implementations should work.
  166.       if (os_fopen(0x40,path,&handle)) { return NULL; }
  167.       r[0] = 7; r[1] = handle; r[2] = (long)resolved_path; r[5] = MAXPATHLEN;
  168.       os_swi(9,r);
  169.       os_fclose(handle);
  170.       #else
  171.       var os_error* err;
  172.       r[0] = 37; r[1] = (long)path; r[2] = (long)resolved_path;
  173.       r[3] = 0; r[4] = 0; r[5] = MAXPATHLEN;
  174.       err = os_swi(0x29,r);
  175.       if (err) { __seterr(err); return NULL; }
  176.       #endif
  177.       if (r[5] <= 0)
  178.         { errno = ENOMEM /* ENAMETOOLONG would be better, but does not yet exist */;
  179.           return NULL;
  180.         }
  181.       return resolved_path;
  182.     }
  183. #endif
  184.  
  185.  
  186. # ==============================================================================
  187. #                         P A T H N A M E S
  188.  
  189. #ifdef PATHNAME_ATARI
  190. # Komponenten:
  191. # HOST          stets NIL
  192. # DEVICE        NIL oder :WILD oder "A"|...|"Z"
  193. # DIRECTORY     (Disknummer Startpoint . Subdirs) wobei
  194. #                Disknummer = NIL oder die Seriennummer der Diskette ist,
  195. #                Startpoint = :RELATIVE | :ABSOLUTE
  196. #                Subdirs = () | (subdir . Subdirs)
  197. #                subdir = :CURRENT (bedeutet ".") oder
  198. #                subdir = :PARENT (bedeutet "..") oder
  199. #                subdir = :WILD-INFERIORS (bedeutet "...", alle Subdirectories) oder
  200. #                subdir = (name . type)
  201. #                 name = :WILD oder Simple-String mit max. 8 Zeichen
  202. #                 type = :WILD oder Simple-String mit max. 3 Zeichen
  203. # NAME          NIL oder :WILD oder Simple-String mit max. 8 Zeichen
  204. # TYPE          NIL oder :WILD oder Simple-String mit max. 3 Zeichen
  205. # VERSION       stets NIL (auch :WILD oder :NEWEST bei Eingabe)
  206. # Wenn ein Pathname vollstΣndig spezifiziert sein mu▀ (keine Wildcards),
  207. # ist :WILD, :WILD-INFERIORS nicht erlaubt, bei NAME evtl. auch nicht NIL.
  208. # Externe Notation: A123456:\sub1.typ\sub2.typ\name.typ
  209. # mit Defaults:             \sub1.typ\sub2.typ\name.typ
  210. # oder                                         name.typ
  211. # oder                    *:\sub1.typ\*.*\name.*
  212. # oder ─hnliches.
  213. #endif
  214.  
  215. #ifdef PATHNAME_MSDOS
  216. # Komponenten:
  217. # HOST          stets NIL
  218. # DEVICE        NIL oder :WILD oder "A"|...|"Z"
  219. # DIRECTORY     (Startpoint . Subdirs) wobei
  220. #                Startpoint = :RELATIVE | :ABSOLUTE
  221. #                Subdirs = () | (subdir . Subdirs)
  222. #                subdir = :CURRENT (bedeutet ".") oder
  223. #                subdir = :PARENT (bedeutet "..") oder
  224. #                subdir = :WILD-INFERIORS (bedeutet "...", alle Subdirectories) oder
  225. #                subdir = (name . type)
  226. #                 name = :WILD oder Simple-String mit max. 8 Zeichen
  227. #                 type = :WILD oder Simple-String mit max. 3 Zeichen
  228. # NAME          NIL oder :WILD oder Simple-String mit max. 8 Zeichen
  229. # TYPE          NIL oder :WILD oder Simple-String mit max. 3 Zeichen
  230. # VERSION       stets NIL (auch :WILD oder :NEWEST bei Eingabe)
  231. # Wenn ein Pathname vollstΣndig spezifiziert sein mu▀ (keine Wildcards),
  232. # ist :WILD, :WILD-INFERIORS nicht erlaubt, bei NAME evtl. auch nicht NIL.
  233. # Externe Notation:       A:\sub1.typ\sub2.typ\name.typ
  234. # mit Defaults:             \sub1.typ\sub2.typ\name.typ
  235. # oder                                         name.typ
  236. # oder                    *:\sub1.typ\*.*\name.*
  237. # oder ─hnliches.
  238. # Statt '\' ist - wie unter DOS ⁿblich - auch '/' erlaubt.
  239. #endif
  240.  
  241. #ifdef PATHNAME_AMIGAOS
  242. # Komponenten:
  243. # HOST          stets NIL
  244. # DEVICE        NIL oder Simple-String
  245. # DIRECTORY     (Startpoint . Subdirs) wobei
  246. #                Startpoint = :RELATIVE | :ABSOLUTE
  247. #                Subdirs = () | (subdir . Subdirs)
  248. #                subdir = :WILD-INFERIORS (bedeutet "**" oder "...", alle Subdirectories) oder
  249. #                subdir = :PARENT (bedeutet "/" statt "subdir/") oder
  250. #                subdir = Simple-String, evtl. mit Wildcard-Zeichen ? und *
  251. # NAME          NIL oder
  252. #               Simple-String, evtl. mit Wildcard-Zeichen ? und *
  253. #               (auch :WILD bei der Eingabe)
  254. # TYPE          NIL oder
  255. #               Simple-String, evtl. mit Wildcard-Zeichen ? und *
  256. #               (auch :WILD bei der Eingabe)
  257. # VERSION       stets NIL (auch :WILD oder :NEWEST bei Eingabe)
  258. # Constraint: Startpoint = :RELATIVE nur, falls Device = NIL;
  259. #             bei angegebenem Device gibt es also nur absolute Pathnames!
  260. # Ein AMIGAOS-Filename wird folgenderma▀en in Name und Typ aufgespalten:
  261. #   falls kein '.' im Filename: Name = alles, Typ = NIL,
  262. #   falls '.' im Filename: Name = alles vor, Typ = alles nach dem letzten '.' .
  263. # Gro▀-/Klein-Schreibung innerhalb der Strings wird bei Vergleichen ignoriert,
  264. # aber ansonsten findet keine Gro▀/Klein-Umwandlung statt.
  265. # Wenn ein Pathname vollstΣndig spezifiziert sein mu▀ (keine Wildcards),
  266. # ist :WILD, :WILD-INFERIORS nicht erlaubt, keine Wildcard-Zeichen in den
  267. # Strings, bei NAME evtl. auch nicht NIL.
  268. # Externe Notation:  device:sub1.typ/sub2.typ/name.typ
  269. # mit Defaults:             sub1.typ/sub2.typ/name.typ
  270. # oder                                        name.typ
  271. # oder                      sub1.typ/ ** /sub3.typ/x*.lsp  (ohne Spaces!)
  272. # oder ─hnliches.
  273. # Formal:
  274. #   ch ::= beliebgiges Character au▀er ':','/' und '*','?'
  275. #   name ::= {ch}+
  276. #   device ::= [ <leer> | ':' | name ':' ]
  277. #              ; leer = aktuelles Device, relativ ab aktuellem Directory
  278. #              ; ':'  = aktuelles Device, absolut (ab root bei Disks)
  279. #              ; name ':' = angegebenes Device, absolut (ab root bei Disks)
  280. #   subdir ::= [ <leer> | name ]                ; leer = '..'
  281. #   pathname ::= device { subdir '/' }* name
  282. # Beispiele:
  283. #   String        Device    Directory                unser Pathname
  284. #   ------        ------    ---------                --------------
  285. #   'c:foo'       'C',     device->foo               "c" (:ABSOLUTE "foo")
  286. #   'c:foo/'      'C',     device->foo               "c" (:ABSOLUTE "foo")
  287. #   'c:foo/bar'   'C',     device->foo->bar          "c" (:ABSOLUTE "foo" "bar")
  288. #   'c:/foo'      'C',     device->up->foo           "c" (:ABSOLUTE :PARENT "foo")
  289. #   'c:'          'C',     device                    "c" (:ABSOLUTE)
  290. #   ':foo'        current, device->root->foo         NIL (:ABSOLUTE "foo")
  291. #   'foo'         current, device->foo               NIL (:RELATIVE "foo")
  292. #   '/foo'        current, device->up->foo           NIL (:RELATIVE :PARENT "foo")
  293. #   '//foo/bar'   current, device->up->up->foo->bar  NIL (:RELATIVE :PARENT :PARENT "foo" "bar")
  294. #   ''            current, device                    NIL (:RELATIVE)
  295. # An einen Pathstring, der nichtleer ist und der nicht mit ':' oder '/'
  296. # endet, kann ein '/' angehΣngt werden, ohne seine Semantik zu verΣndern.
  297. # Dieser '/' mu▀ angehΣngt werden, bevor man eine weitere nichtleere
  298. # Komponente anhΣngen kann.
  299. # An einen Pathstring, der leer ist oder mit ':' oder '/' endet, ein '/'
  300. # anzuhΣngen, bedeutet aber, zum Parent Directory aufzusteigen!
  301. # Bei uns wird jeder Pathstring, der leer ist oder mit ':' oder '/' endet,
  302. # als Directory-Pathname (mit Name=NIL und Type=NIL) interpretiert.
  303. #endif
  304.  
  305. #ifdef PATHNAME_UNIX
  306. # Komponenten:
  307. # HOST          stets NIL
  308. # DEVICE        stets NIL
  309. # DIRECTORY     (Startpoint . Subdirs) wobei
  310. #                Startpoint = :RELATIVE | :ABSOLUTE
  311. #                Subdirs = () | (subdir . Subdirs)
  312. #                subdir = :WILD-INFERIORS (bedeutet "**" oder "...", alle Subdirectories) oder
  313. #                subdir = Simple-String, evtl. mit Wildcard-Zeichen ? und *
  314. # NAME          NIL oder
  315. #               Simple-String, evtl. mit Wildcard-Zeichen ? und *
  316. #               (auch :WILD bei der Eingabe)
  317. # TYPE          NIL oder
  318. #               Simple-String, evtl. mit Wildcard-Zeichen ? und *
  319. #               (auch :WILD bei der Eingabe)
  320. # VERSION       stets NIL (auch :WILD oder :NEWEST bei Eingabe)
  321. # Ein UNIX-Filename wird folgenderma▀en in Name und Typ aufgespalten:
  322. #   falls kein '.' im Filename: Name = alles, Typ = NIL,
  323. #   falls '.' im Filename: Name = alles vor, Typ = alles nach dem letzten '.' .
  324. # Wenn ein Pathname vollstΣndig spezifiziert sein mu▀ (keine Wildcards),
  325. # ist :WILD, :WILD-INFERIORS nicht erlaubt, keine Wildcard-Zeichen in den
  326. # Strings, bei NAME evtl. auch nicht NIL.
  327. # Externe Notation:  server:/sub1.typ/sub2.typ/name.typ
  328. # mit Defaults:             /sub1.typ/sub2.typ/name.typ
  329. # oder                                         name.typ
  330. # oder                      /sub1.typ/ ** /sub3.typ/x*.lsp  (ohne Spaces!)
  331. # oder ─hnliches.
  332. #endif
  333.  
  334. #ifdef PATHNAME_OS2
  335. # Komponenten:
  336. # HOST          stets NIL
  337. # DEVICE        NIL oder :WILD oder "A"|...|"Z"
  338. # DIRECTORY     (Startpoint . Subdirs) wobei
  339. #                Startpoint = :RELATIVE | :ABSOLUTE
  340. #                Subdirs = () | (subdir . Subdirs)
  341. #                subdir = :WILD-INFERIORS (bedeutet "**" oder "...", alle Subdirectories) oder
  342. #                subdir = Simple-String, evtl. mit Wildcard-Zeichen ? und *
  343. # NAME          NIL oder
  344. #               Simple-String, evtl. mit Wildcard-Zeichen ? und *
  345. #               (auch :WILD bei der Eingabe)
  346. # TYPE          NIL oder
  347. #               Simple-String, evtl. mit Wildcard-Zeichen ? und *
  348. #               (auch :WILD bei der Eingabe)
  349. # VERSION       stets NIL (auch :WILD oder :NEWEST bei Eingabe)
  350. # Ein OS/2-Filename wird folgenderma▀en in Name und Typ aufgespalten:
  351. #   falls kein '.' im Filename: Name = alles, Typ = NIL,
  352. #   falls '.' im Filename: Name = alles vor, Typ = alles nach dem letzten '.' .
  353. # Wenn ein Pathname vollstΣndig spezifiziert sein mu▀ (keine Wildcards),
  354. # ist :WILD, :WILD-INFERIORS nicht erlaubt, keine Wildcard-Zeichen in den
  355. # Strings, bei NAME evtl. auch nicht NIL.
  356. # Externe Notation:       A:\sub1.typ\sub2.typ\name.typ
  357. # mit Defaults:             \sub1.typ\sub2.typ\name.typ
  358. # oder                                         name.typ
  359. # oder                    *:\sub1.typ\**\sub3.typ\x*.lsp
  360. # oder ─hnliches.
  361. # Statt '\' ist - wie unter DOS ⁿblich - auch '/' erlaubt.
  362. #endif
  363.  
  364. #ifdef PATHNAME_RISCOS
  365. #
  366. # Peter Burwood <clisp@arcangel.demon.co.uk> writes:
  367. #
  368. # RISC OS provides several filing systems as standard (ADFS, IDEFS, NetFS,
  369. # RamFS, NetPrint) and support for extra filing systems (DOSFS, ResourceFS and
  370. # DeviceFS).
  371. #
  372. # A module called FileSwitch is at the centre of all filing system operation
  373. # in RISC OS. FileSwicth provides a common core of functions used by all
  374. # filing systems. It only provides the parts of these services that are device
  375. # independent. The device dependant services that control the hardware are
  376. # provided by separate modules, which are the actual filing systems.
  377. # FileSwitch keeps track of active filing systems and switches betwen them as
  378. # necessary.
  379. #
  380. # One of the filing system modules that RISC OS provides is FileCore. It takes
  381. # the normal calls that FileSwitch sneds to a filing system module, and
  382. # converts them to a simpler set of calls to modules that control the
  383. # hardware. Unlike FileSwitch it creates a fresh instantiation of itself for
  384. # each module that it supports. Using FileCore to build filing system modules
  385. # imposes a more rigid structure on it, as more of the filing system is
  386. # predefined.
  387. #
  388. # As well as standard filing systems, FileSwitch supports image filing
  389. # systems. These provide facilities for RISC OS to handle media in foreign
  390. # formats, and to support `image files' (or partitions) in those formats.
  391. # Rather than accessing the hardware directly they rely on standard RISC OS
  392. # filing systems to do so. DOSFS is an example of an image filing system used
  393. # to handle DOS format discs.
  394. #
  395. # Terminology
  396. #
  397. # A pathname may include a filing system name, a special field, a media name
  398. # (e.g., a disc name), directory name(s), and the name of the object itself;
  399. # each of these parts of a pathname is known as an `element' of the pathname.
  400. #
  401. # Filenames
  402. #
  403. # Filename `elements' may be up to ten characters in length on FileCore-based
  404. # filing systems and on NetFS. These characters may be digits or letters.
  405. # FileSwitch makes no distinction between upper and lower case, although
  406. # filing systems can do so. As a general rule, you should not use top-bit-set
  407. # characters in filenames, although some filing systems (such as
  408. # FileCore-based ones) support them. Other characters may be used provided
  409. # they do not have a special significance. Those that do are listed below :
  410. #
  411. #    .   Separates directory specifications, e.g., $.fred
  412. #    :   Introduces a drive or disc specification, e.g., :0, :bigdisc. It also
  413. #        marks the end of a filing system name, e.g., adfs:
  414. #    *   Acts as a `wildcard' to match zero or more characters.
  415. #    #   Acts as a `wildcard' to match any single character.
  416. #    $   is the name of the root directory of the disc.
  417. #    &   is the user root directory (URD)
  418. #    @   is the currently selected directory (CSD)
  419. #    ^   is the `parent' directory
  420. #    %   is the currently selected library (CSL)
  421. #    \   is the previously selected directory (PSD)
  422. #
  423. # Directories
  424. #
  425. # The root directory, $, forms the top of the directory hierarchy
  426. # of the media which contains the CSD. $ does not have a parent directory,
  427. # trying to access its parent will just access $. Each directory name is
  428. # separated by a '.' character. For example:
  429. #
  430. #    $.Documents.Memos
  431. #    %.cc
  432. #
  433. # Filing Systems
  434. #
  435. # Files may also be accessed on filing systems other than the current one by
  436. # prefixing the filename with a filing system specification. A filing system
  437. # name may appear between '-' characters, or suffixed by a ':', though the
  438. # latter is advised since '-' can also be used to introduce a parameter on a
  439. # command line, or as part of a file name. For example:
  440. #
  441. #    -net-$.SystemMesg
  442. #    adfs:%.aasm
  443. #
  444. # Special Fields
  445. #
  446. # Special fields are used to supply more information to the filing system than
  447. # you can using standard path names; for example NetFS and NetPrint use them
  448. # to specify server addresses or names. They are introduced by a '#'
  449. # character; a variety of syntaxes are possible:
  450. #
  451. #    net#MJHardy::disc1.mike
  452. #       #MJHardy::disc1.mike
  453. #   -net#MJHardy-:disc1.mike
  454. #      -#MJHardy-:disc1.mike
  455. #
  456. # The special fields here are all MJHardy, and give the name of the fileserver
  457. # to use. Special fields may use any character except for control characters,
  458. # double quote '"', solidus '|' and space. If a special field contains a hypen
  459. # you may only use the first two syntaxes given above.
  460. #
  461. # File$Path and Run$Path
  462. #
  463. # These two special variables control exactly where a file will be looked for,
  464. # according to the operation being performed on it.
  465. #
  466. #    File$Path   for read operations
  467. #    Run$Path    for execute operations
  468. #
  469. # The contents of each variable should expand to a list or prefixes, separated
  470. # by commas. When a read operation is performed then the prefixes in File$Path
  471. # are used in the order in which they are listed. The first object that
  472. # matches is used, whether it be a file or directory. Similarly any execute
  473. # operation uses the prefixes in Run$Path. These search paths are only used
  474. # when the pathname does not contain an explicit filing system reference,
  475. # e.g., executing adfs:file will not use Run$Path.
  476. #
  477. # Other path variables
  478. #
  479. # You can set up other path variables and use them as pseudo filing systems.
  480. # For example if you typed:
  481. #
  482. #    *Set Source$Path adfs:$.src.,adfs:$.public.src.
  483. #
  484. # you could then refer to the pseudo filing system as Source: or (less
  485. # preferable) as -Source-. These path variables work in the same was as
  486. # File$Path and Run$Path.
  487. #
  488. #
  489. # from Lisp-string notation to internal representation
  490. # ----------------------------------------------------
  491. # NO swapping. "foo.lsp" means file type "lsp" and file name "foo".
  492. # This is pseudo-BNF:
  493. #
  494. # legal character ::= any ISO latin-1 graphic character >= ' ' except
  495. #                     '.' ':' '*' '#' '$' '&' '@' '^' '%' '\' '?'
  496. #
  497. # extended legal character ::= any ISO latin-1 graphic character >= ' ' except
  498. #                              ':' '"' '|'
  499. #
  500. # legal-wild char ::= legal char | '*' | '#' | '?'
  501. #
  502. # host ::=   '-' { extended legal char except '-' }+ '-'
  503. #          | { extended legal char except '-' } { extended legal char }* ':'
  504. #          | empty
  505. #
  506. # device ::=   ':' { legal char }+ '.'
  507. #            | empty
  508. #
  509. # directory ::=   { '$' | '&' | '@' | '%' | '\' } '.' { subdirectory }*
  510. #               | { subdirectory }+
  511. #               | empty
  512. # In the first case, '&', '%', '\' get resolved. (Or maybe they are not
  513. # yet resolved, but get treated similarly to '@' -> :ABSOLUTE :CURRENT.)
  514. # '$' -> :ABSOLUTE :ROOT, '@' -> :ABSOLUTE :CURRENT, else :RELATIVE.
  515. #
  516. # subdirectory ::= { '^' | { legal-wild char }+ } '.'
  517. #                  '^' -> :PARENT
  518. #
  519. # filename ::= { { legal-wild char }+ | empty }
  520. #
  521. # filetype ::= { '.' { legal-wild char }+ | empty }
  522. #
  523. # pathname ::= host device directory filename filetype
  524. #
  525. # Examples:
  526. # String                          Hostname Device  Directory            Name         Type
  527. # -net-$.SystemMesg                "net"   NIL     (:ABSOLUTE :ROOT)    "SystemMesg" NIL
  528. # net#MJHardy::disc1.mike    "net#MJHardy" "disc1" (:ABSOLUTE :ROOT)    "mike"       NIL
  529. # #MJHardy::disc1.mike          "#MJHardy" "disc1" (:ABSOLUTE :ROOT)    "mike"       NIL
  530. # -net#MJHardy-:disc1.mike   "net#MJHardy" "disc1" (:ABSOLUTE :ROOT)    "mike"       NIL
  531. # -#MJHardy-:disc1.mike         "#MJHardy" "disc1" (:ABSOLUTE :ROOT)    "mike"       NIL
  532. # @.foo                            NIL     NIL     (:ABSOLUTE :CURRENT) "foo"        NIL
  533. # foo                              NIL     NIL     (:RELATIVE)          "foo"        NIL
  534. # ^.                               NIL     NIL     (:RELATIVE :PARENT)  NIL          NIL
  535. # @.^.                             NIL     NIL     (:ABSOLUTE :CURRENT :PARENT) NIL  NIL
  536. # foo.bar                          NIL     NIL     (:RELATIVE)          "foo"        "bar"
  537. # foo.bar.baz                      NIL     NIL     (:RELATIVE "foo")    "bar"        "baz"
  538. # foo.bar.                         NIL     NIL     (:RELATIVE "foo" "bar") NIL       NIL
  539. # foo.@.                       illegal
  540. #
  541. # from internal representation to RISCOS string
  542. # ---------------------------------------------
  543. #
  544. # with swapping _only_ of name/type components.
  545. # Assume '%' refers to "$.lib."
  546. #
  547. # Hostname    Device  Directory                   Name    Type      RISCOS String
  548. #
  549. # "net"       "disc1" (:ABSOLUTE :ROOT)           "foo"   NIL       "net::disc1.$.foo"
  550. # "net#MJ"    "disc1" (:ABSOLUTE :ROOT "foo")     "bar"   "baz"     "net#MJ::disc1.$.foo.baz.bar"
  551. # "adfs"      "4"     (:ABSOLUTE :ROOT "foo" "bar") NIL   NIL       "adfs::4.$.foo.bar"
  552. # NIL         "disc1" (:ABSOLUTE :ROOT "foo")     "bar"   NIL       ":disc1.$.foo.bar"
  553. # NIL         "disc1" (:ABSOLUTE :CURRENT)        NIL     NIL       illegal here
  554. # NIL         "disc1" (:RELATIVE)                 NIL     NIL       ":disc1."
  555. # NIL         "disc1" NIL                         NIL     NIL       ":disc1."
  556. # NIL         NIL     (:ABSOLUTE :ROOT)           "foo"   NIL       "$.foo"
  557. # NIL         NIL     (:ABSOLUTE :CURRENT)        "foo"   NIL       "@.foo"
  558. # NIL         NIL     (:RELATIVE)                 "foo"   "bar"     "bar.foo"
  559. # NIL         NIL     (:RELATIVE "foo")           "bar"   "baz"     "foo.baz.bar"
  560. # NIL         NIL     (:ABSOLUTE :ROOT "%")       "bar"   NIL       "$.lib.bar"
  561. # NIL         NIL     (:ABSOLUTE :ROOT "%" "foo") "bar"   NIL       "$.lib.foo.bar"
  562. # NIL         NIL     (:RELATIVE)                 "foo"   "bar"     "bar.foo"
  563. # NIL         NIL     (:RELATIVE "foo")           "bar"   NIL       "foo.bar"
  564. # NIL         NIL     (:RELATIVE "foo")           NIL     "bar"     illegal here
  565. #
  566. # That is, the RISCOS string is the flattenation-concatenation of
  567. #   (append
  568. #     (if (null hostname) "" (append hostname ":"))
  569. #     (if (null device) "" (append ":" device "."))
  570. #     (case (pop directory)
  571. #       (:ABSOLUTE (case (pop directory) (:ROOT "$.") (:CURRENT "@.")))
  572. #       (:RELATIVE "")
  573. #     )
  574. #     (mapcar (lambda (subdir) (append subdir ".")) directory)
  575. #     (if (null name)
  576. #       (if (null type) "" (error "type with name illegal here"))
  577. #       (if (null type)
  578. #         name
  579. #         (append type "." name)
  580. #   ) ) )
  581. #
  582. # internal representation
  583. # -----------------------
  584. #
  585. # Komponenten:
  586. # HOST          Simple-String oder NIL
  587. # DEVICE        Simple-String oder NIL
  588. # DIRECTORY     (Startpoint . Subdirs) wobei
  589. #                Startpoint = :RELATIVE | :ABSOLUTE Anker
  590. #                Anker = :ROOT | :HOME | :CURRENT | :LIBRARY | :PREVIOUS
  591. #                Subdirs = () | (subdir . Subdirs)
  592. #                subdir = :PARENT oder
  593. #                subdir = Simple-String, evtl. mit Wildcard-Zeichen ? und *
  594. # NAME          NIL oder
  595. #               Simple-String, evtl. mit Wildcard-Zeichen ? und *
  596. #               (auch :WILD bei der Eingabe)
  597. # TYPE          NIL oder
  598. #               Simple-String, evtl. mit Wildcard-Zeichen ? und *
  599. #               (auch :WILD bei der Eingabe)
  600. # VERSION       stets NIL (auch :WILD oder :NEWEST bei Eingabe)
  601. #
  602. #endif
  603.  
  604. #ifdef LOGICAL_PATHNAMES
  605. # Komponenten von Logical Pathnames:
  606. # HOST          Simple-String oder NIL
  607. # DEVICE        stets NIL
  608. # DIRECTORY     (Startpoint . Subdirs) wobei
  609. #                Startpoint = :RELATIVE | :ABSOLUTE
  610. #                Subdirs = () | (subdir . Subdirs)
  611. #               subdir = :WILD-INFERIORS (bedeutet "**", alle Subdirectories) oder
  612. #               subdir = :WILD (bedeutet "*") oder
  613. #               subdir = Simple-String, evtl. mit Wildcard-Zeichen *
  614. # NAME          NIL oder
  615. #               :WILD (bedeutet "*") oder
  616. #               Simple-String, evtl. mit Wildcard-Zeichen *
  617. # TYPE          NIL oder
  618. #               :WILD (bedeutet "*") oder
  619. #               Simple-String, evtl. mit Wildcard-Zeichen *
  620. # VERSION       NIL oder :NEWEST oder :WILD oder Integer
  621. # Externe Notation: siehe CLtl2 S. 628-629.
  622. #endif
  623.  
  624. # Wandelt Gro▀-/Klein-Schreibung zwischen :LOCAL und :COMMON um.
  625. # common_case(string)
  626. # > string: Simple-String oder Symbol/Zahl
  627. # < ergebnis: umgewandelter Simple-String oder dasselbe Symbol/Zahl
  628. # kann GC ausl÷sen
  629.   local object common_case (object string);
  630. # Dasselbe, rekursiv wie mit SUBST:
  631.   local object subst_common_case (object obj);
  632. #if defined(PATHNAME_UNIX) || defined(PATHNAME_OS2) || defined(PATHNAME_RISCOS) || defined(PATHNAME_AMIGAOS)
  633.   # Betriebssystem mit Vorzug fⁿr Kleinbuchstaben oder Capitalize
  634.   local object common_case(string)
  635.     var reg6 object string;
  636.     { if (!simple_string_p(string))
  637.         return string;
  638.      {var reg7 uintL len = TheSstring(string)->length;
  639.       # Suche, ob Gro▀- oder Kleinbuchstaben (oder beides) vorkommen:
  640.       var reg5 boolean all_upper = TRUE;
  641.       var reg4 boolean all_lower = TRUE;
  642.       { var reg2 uintB* ptr = &TheSstring(string)->data[0];
  643.         var reg3 uintL count;
  644.         dotimesL(count,len,
  645.           { var reg1 uintB ch = *ptr++;
  646.             if (!(ch == up_case(ch))) { all_upper = FALSE; }
  647.             if (!(ch == down_case(ch))) { all_lower = FALSE; }
  648.             if (!all_upper && !all_lower) break;
  649.           });
  650.       }
  651.       if (all_upper == all_lower)
  652.         # all_upper = all_lower = TRUE: Nichts zu konvertieren.
  653.         # all_upper = all_lower = FALSE: "Mixed case represents itself."
  654.         return string;
  655.       if (all_upper)
  656.         # all_upper = TRUE, all_lower = FALSE: STRING-DOWNCASE
  657.         return string_downcase(string);
  658.         else
  659.         # all_upper = FALSE, all_lower = TRUE: STRING-UPCASE
  660.         return string_upcase(string);
  661.     }}
  662.   local object subst_common_case(obj)
  663.     var reg1 object obj;
  664.     { if (atomp(obj))
  665.         { return common_case(obj); }
  666.       check_STACK(); check_SP();
  667.       pushSTACK(obj);
  668.       # rekursiv fⁿr den CAR aufrufen:
  669.       { var reg2 object new_car = subst_common_case(Car(obj));
  670.         pushSTACK(new_car);
  671.       }
  672.       # rekursiv fⁿr den CDR aufrufen:
  673.       { var reg2 object new_cdr = subst_common_case(Cdr(STACK_1));
  674.         if (eq(new_cdr,Cdr(STACK_1)) && eq(STACK_0,Car(STACK_1)))
  675.           { obj = STACK_1; skipSTACK(2); return obj; }
  676.           else
  677.           # (CONS new_car new_cdr)
  678.           { STACK_1 = new_cdr;
  679.            {var reg1 object new_cons = allocate_cons();
  680.             Car(new_cons) = popSTACK(); Cdr(new_cons) = popSTACK();
  681.             return new_cons;
  682.     } }   }}
  683. #else # defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS)
  684.   # Betriebssystem mit Vorzug fⁿr Gro▀buchstaben
  685.   #define common_case(string)  string
  686.   #define subst_common_case(obj)  obj
  687. #endif
  688.  
  689. #ifdef LOGICAL_PATHNAMES
  690.  
  691. local boolean legal_logical_word_char (uintB ch);
  692. local boolean legal_logical_word_char(ch)
  693.   var reg1 uintB ch;
  694.   { ch = up_case(ch);
  695.     if (((ch >= 'A') && (ch <= 'Z'))
  696.         || ((ch >= '0') && (ch <= '9'))
  697.         || (ch == '-')
  698.        )
  699.       return TRUE;
  700.       else
  701.       return FALSE;
  702.   }
  703.  
  704. #endif
  705.  
  706. #if HAS_HOST
  707.  
  708. # UP: Stellt fest, ob ein Character als Zeichen im Host-Teil eines Namestring
  709. # erlaubt ist.
  710. # legal_hostchar(ch)
  711. # > uintB ch: Character-Code
  712. # < ergebnis: TRUE falls erlaubt, FALSE sonst
  713.   local boolean legal_hostchar (uintB ch);
  714. # NB: legal_logical_word_char(ch) impliziert legal_hostchar(ch).
  715.   local boolean legal_hostchar(ch)
  716.     var reg1 uintB ch;
  717.     {
  718.       #ifdef PATHNAME_RISCOS
  719.       return (graphic_char_p(ch) && !(ch==':') && !(ch=='"') && !(ch=='|'));
  720.       #else
  721.       return alphanumericp(ch) || (ch=='-');
  722.       #endif
  723.     }
  724.  
  725. # UP: ▄berprⁿft ein optionales Host-Argument.
  726. # test_optional_host(host,convert)
  727. # > host: Host-Argument
  728. # > convert: Flag, ob Case-Konversion erwⁿnscht ist
  729. # > subr_self: Aufrufer (ein SUBR)
  730. # < ergebnis: gⁿltige Host-Komponente
  731. # kann GC ausl÷sen
  732.   local object test_optional_host (object host, boolean convert);
  733.   local object test_optional_host(host,convert)
  734.     var reg4 object host;
  735.     var reg5 boolean convert;
  736.     { if (eq(host,unbound)) { return NIL; } # nicht angegeben -> NIL
  737.       if (nullp(host)) goto OK; # NIL ist OK
  738.       # Sonst mu▀ host ein String sein, dessen Zeichen alphanumerisch sind:
  739.       if (!stringp(host))
  740.         { pushSTACK(host); # Wert fⁿr Slot DATUM von TYPE-ERROR
  741.           pushSTACK(O(type_host)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  742.           pushSTACK(host);
  743.           pushSTACK(TheSubr(subr_self)->name);
  744.           fehler(type_error,
  745.                  DEUTSCH ? "~: Host mu▀ NIL oder ein String sein, nicht ~" :
  746.                  ENGLISH ? "~: host should be NIL or a string, not ~" :
  747.                  FRANCAIS ? "~ : Le nom de machine h⌠te doit Ωtre NIL ou de type STRING et non ~" :
  748.                  ""
  749.                 );
  750.         }
  751.       host = coerce_ss(host); # als Simple-String
  752.       if (convert) { host = common_case(host); }
  753.       { var reg3 uintL len = TheSstring(host)->length;
  754.         var reg2 uintB* charptr = &TheSstring(host)->data[0];
  755.         dotimesL(len,len,
  756.           { var reg1 uintB ch = *charptr++;
  757.             if (!legal_hostchar(ch)) goto badhost;
  758.           });
  759.       }
  760.       OK: return host;
  761.       badhost:
  762.         { pushSTACK(host);
  763.           pushSTACK(TheSubr(subr_self)->name);
  764.           fehler(error,
  765.                  DEUTSCH ? "~: syntaktisch illegaler Hostname ~" :
  766.                  ENGLISH ? "~: illegal hostname ~" :
  767.                  FRANCAIS ? "~ : Syntaxe incorrecte pour un nom de machine h⌠te: ~" :
  768.                  ""
  769.                 );
  770.         }
  771.     }
  772.  
  773. #else
  774.  
  775. #ifdef LOGICAL_PATHNAMES
  776.  
  777. # UP: ▄berprⁿft ein optionales Host-Argument.
  778. # test_optional_host(host)
  779. # > host: Host-Argument
  780. # > subr_self: Aufrufer (ein SUBR)
  781. # < ergebnis: gⁿltige Host-Komponente
  782. # kann GC ausl÷sen
  783.   local object test_optional_host (object host);
  784.   local object test_optional_host(host)
  785.     var reg4 object host;
  786.     { if (eq(host,unbound)) { return NIL; } # nicht angegeben -> NIL
  787.       if (nullp(host)) goto OK; # NIL ist OK
  788.       # Sonst mu▀ host ein String sein, dessen Zeichen alphanumerisch sind:
  789.       if (!stringp(host))
  790.         { pushSTACK(host); # Wert fⁿr Slot DATUM von TYPE-ERROR
  791.           pushSTACK(O(type_host)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  792.           pushSTACK(host);
  793.           pushSTACK(TheSubr(subr_self)->name);
  794.           fehler(type_error,
  795.                  DEUTSCH ? "~: Host mu▀ NIL oder ein String sein, nicht ~" :
  796.                  ENGLISH ? "~: host should be NIL or a string, not ~" :
  797.                  FRANCAIS ? "~ : Le nom de machine h⌠te doit Ωtre NIL ou de type STRING et non ~" :
  798.                  ""
  799.                 );
  800.         }
  801.       host = coerce_ss(host); # als Simple-String
  802.       { var reg3 uintL len = TheSstring(host)->length;
  803.         var reg2 uintB* charptr = &TheSstring(host)->data[0];
  804.         dotimesL(len,len,
  805.           { var reg1 uintB ch = *charptr++;
  806.             if (!legal_logical_word_char(ch)) goto badhost;
  807.           });
  808.       }
  809.       OK: return host;
  810.       badhost:
  811.         { pushSTACK(host);
  812.           pushSTACK(TheSubr(subr_self)->name);
  813.           fehler(error,
  814.                  DEUTSCH ? "~: syntaktisch illegaler Hostname ~" :
  815.                  ENGLISH ? "~: illegal hostname ~" :
  816.                  FRANCAIS ? "~ : Syntaxe incorrecte pour un nom de machine h⌠te: ~" :
  817.                  ""
  818.                 );
  819.         }
  820.     }
  821.  
  822. #else
  823.  
  824. # UP: ▄berprⁿft ein optionales Host-Argument.
  825. # test_optional_host(host);
  826. # > host: Host-Argument
  827. # > subr_self: Aufrufer (ein SUBR)
  828. # < ergebnis: gⁿltige Host-Komponente
  829.   local object test_optional_host (object host);
  830.   local object test_optional_host(host)
  831.     var reg1 object host;
  832.     { if (!eq(host,unbound)) # nicht angegeben -> OK
  833.         { if (!nullp(host)) # angegeben -> sollte =NIL sein
  834.             { pushSTACK(host); # Wert fⁿr Slot DATUM von TYPE-ERROR
  835.               pushSTACK(S(null)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  836.               pushSTACK(host);
  837.               pushSTACK(TheSubr(subr_self)->name);
  838.               fehler(type_error,
  839.                      DEUTSCH ? "~: Host mu▀ NIL sein, nicht ~" :
  840.                      ENGLISH ? "~: host should be NIL, not ~" :
  841.                      FRANCAIS ? "~ : Le nom de machine h⌠te doit Ωtre NIL et non ~" :
  842.                      ""
  843.                     );
  844.             }
  845.         }
  846.       return NIL;
  847.     }
  848.  
  849. #endif
  850.  
  851. #endif
  852.  
  853. # Stellt fest, ob zwei Characters als Zeichen in Pathnames als gleich gelten.
  854. # equal_pathchar(ch1,ch2)
  855. # > uintB ch1,ch2: Character-Codes
  856. # < ergebnis: TRUE falls gleich, FALSE sonst
  857.   #if !(defined(PATHNAME_AMIGAOS) || defined(PATHNAME_OS2))
  858.     #define equal_pathchar(ch1,ch2)  ((ch1)==(ch2))
  859.   #else # defined(PATHNAME_AMIGAOS) || defined(PATHNAME_OS2)
  860.     # Case-insensitive, aber normalerweise ohne Konversion
  861.     #define equal_pathchar(ch1,ch2)  (up_case(ch1)==up_case(ch2))
  862.   #endif
  863.  
  864. # UP: Stellt fest, ob ein Character als Zeichen im Namens-/Typ-Teil eines
  865. # Namestring erlaubt ist.
  866. # legal_namechar(ch)
  867. # > uintB ch: Character-Code
  868. # < ergebnis: TRUE falls erlaubt, FALSE sonst
  869.   local boolean legal_namechar (uintB ch);
  870.   local boolean legal_namechar(ch)
  871.     var reg1 uintB ch;
  872.     {
  873.       #if defined(PATHNAME_ATARI) || 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.     }
  893.  
  894. # Stellt fest, ob ein Character ein Wildcard-Platzhalter fⁿr ein einzelnes
  895. # Zeichen ist.
  896. # singlewild_char_p(ch)
  897. # > uintB ch: Character-Code
  898. # < ergebnis: TRUE falls ja, FALSE sonst
  899.   #if !defined(PATHNAME_RISCOS)
  900.     #define singlewild_char_p(ch)  ((ch)=='?')
  901.   #else # defined(PATHNAME_RISCOS)
  902.     #define singlewild_char_p(ch)  (((ch)=='?') || ((ch)=='#'))
  903.   #endif
  904.  
  905. # Wandelt ein Objekt in einen Pathname um.
  906.   local object coerce_xpathname (object obj); # spΣter
  907.  
  908. # Wandelt ein Objekt in einen nicht-Logical Pathname um.
  909.   local object coerce_pathname (object obj); # spΣter
  910. #if !defined(LOGICAL_PATHNAMES)
  911.   #define coerce_pathname(obj)  coerce_xpathname(obj)
  912. #endif
  913.  
  914. # Liefert den Default-Pathname.
  915.   local object defaults_pathname (void); # spΣter
  916.  
  917. # ▄berprⁿft einen Default-Pathname.
  918. # test_default_pathname(defaults)
  919. # > defaults: Defaults-Argument
  920. # < ergebnis: Wert des Defaults-Arguments, ein Pathname
  921. # kann GC ausl÷sen
  922.   local object test_default_pathname (object defaults);
  923.   local object test_default_pathname(defaults)
  924.     var reg1 object defaults;
  925.     { if (eq(defaults,unbound))
  926.         # nicht angegeben -> Wert von *DEFAULT-PATHNAME-DEFAULTS* nehmen:
  927.         { return defaults_pathname(); }
  928.         else
  929.         # angegeben -> zu einem Pathname machen:
  930.         { return coerce_xpathname(defaults); }
  931.     }
  932.  
  933. # Fehlermeldung wegen illegalem Pathname-Argument.
  934. # fehler_thing(thing);
  935. # > thing: (fehlerhaftes) Argument
  936. # > subr_self: Aufrufer (ein SUBR)
  937.   nonreturning_function(local, fehler_thing, (object thing));
  938.   local void fehler_thing(thing)
  939.     var reg1 object thing;
  940.     { pushSTACK(thing);
  941.       pushSTACK(TheSubr(subr_self)->name);
  942.       fehler(error, # type_error ??
  943.              DEUTSCH ? "~: Argument mu▀ ein String, Symbol, File-Stream oder Pathname sein, nicht ~" :
  944.              ENGLISH ? "~: argument should be a string, symbol, file stream or pathname, not ~" :
  945.              FRANCAIS ? "~ : L'argument doit Ωtre une chaεne, un symbole, un ½stream╗ de fichier ou un ½pathname╗ et non ~" :
  946.              ""
  947.             );
  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)
  969.  
  970. #if defined(UNIX) || defined(MSDOS)
  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 = *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. # Test auf Ziffernfolge:
  1079. local boolean all_digits (object string);
  1080. local boolean all_digits(string)
  1081.   var reg4 object string;
  1082.   { var reg2 uintB* charptr = &TheSstring(string)->data[0];
  1083.     var reg3 uintL len = TheSstring(string)->length;
  1084.     dotimesL(len,len,
  1085.       { var reg1 uintB ch = *charptr++;
  1086.         if (!((ch >= '0') && (ch <= '9'))) return FALSE;
  1087.       });
  1088.     return TRUE;
  1089.   }
  1090.  
  1091. local uintL parse_logical_pathnamestring(z)
  1092.   var zustand z;
  1093.   { # Host-Specification parsen:
  1094.     { var reg5 object host;
  1095.       var zustand startz = z; # Start-Zustand
  1096.       var reg1 uintB ch;
  1097.       # Kommt eine Folge von alphanumerischen Zeichen und dann ein ':' ?
  1098.       loop
  1099.         { if (z.count==0) goto no_hostspec; # String schon zu Ende -> kein Host
  1100.           ch = TheSstring(STACK_1)->data[z.index]; # nΣchstes Character
  1101.           if (!legal_logical_word_char(ch)) break;
  1102.           # alphanumerisches Character ⁿbergehen:
  1103.           z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1104.         }
  1105.       if (!(ch==':')) goto no_hostspec; # kein ':' -> kein Host
  1106.       # Host-String bilden:
  1107.       { var reg4 uintL len = z.index - startz.index;
  1108.         host = allocate_string(len);
  1109.         # und fⁿllen:
  1110.        {var reg2 uintB* ptr1 = &TheSstring(STACK_1)->data[startz.index];
  1111.         var reg3 uintB* ptr2 = &TheSstring(host)->data[0];
  1112.         dotimesL(len,len, { *ptr2++ = up_case(*ptr1++); });
  1113.       }}
  1114.       # Character ':' ⁿbergehen:
  1115.       z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1116.       goto hostspec_ok;
  1117.      no_hostspec: # keine Host-Specification
  1118.       z = startz; # zum Start zurⁿck
  1119.       host = STACK_(3+2); # Default-Host
  1120.      hostspec_ok:
  1121.       # Host eintragen:
  1122.       TheLogpathname(STACK_0)->pathname_host = host;
  1123.     }
  1124.     # Directory-Start eintragen:
  1125.     { var reg1 object new_cons = allocate_cons(); # neues Cons fⁿr Startpoint
  1126.       TheLogpathname(STACK_0)->pathname_directory = new_cons;
  1127.       pushSTACK(new_cons); # neues (last (pathname-directory Pathname))
  1128.     }
  1129.     # Stackaufbau: Datenvektor, Pathname, (last (pathname-directory Pathname)).
  1130.     # Subdirectories parsen:
  1131.     # Falls sofort ein ';' kommt, wird er ⁿbergangen, und es kommt :RELATIVE
  1132.     # (sonst :ABSOLUTE) als erstes subdir:
  1133.     if ((!(z.count == 0)) && slashp(TheSstring(STACK_2)->data[z.index]))
  1134.       # Es kommt sofort ein ';'.
  1135.       { # Character ⁿbergehen:
  1136.         z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1137.         Car(STACK_0) = S(Krelative); # Startpoint = :RELATIVE
  1138.       }
  1139.       else
  1140.       # Es kommt nicht sofort ein ';'.
  1141.       { Car(STACK_0) = S(Kabsolute); } # Startpoint = :ABSOLUTE
  1142.     loop
  1143.       { # Versuche, ein weiteres Unterdirectory zu parsen.
  1144.         var reg2 object subdir = parse_logical_word(&z,TRUE);
  1145.         if (nullp(subdir)) break;
  1146.         # (pathname-directory pathname) um Subdir verlΣngern:
  1147.         pushSTACK(subdir);
  1148.        {var reg1 object new_cons = allocate_cons(); # neues Cons
  1149.         Car(new_cons) = popSTACK(); # = (cons subdir NIL)
  1150.         Cdr(STACK_0) = new_cons; # verlΣngert (pathname-directory Pathname)
  1151.         STACK_0 = new_cons; # neues (last (pathname-directory Pathname))
  1152.       }}
  1153.     # Name parsen:
  1154.     { var reg1 object name = parse_logical_word(&z,FALSE);
  1155.       TheLogpathname(STACK_1)->pathname_name = name;
  1156.       if ((z.count > 0) && (TheSstring(STACK_2)->data[z.index]=='.'))
  1157.         { var zustand z_name = z;
  1158.           # Character '.' ⁿbergehen:
  1159.           z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1160.           # Typ parsen:
  1161.          {var reg2 object type = parse_logical_word(&z,FALSE);
  1162.           TheLogpathname(STACK_1)->pathname_type = type;
  1163.           if (!nullp(type))
  1164.             { if ((z.count > 0) && (TheSstring(STACK_2)->data[z.index]=='.'))
  1165.                 { var zustand z_type = z;
  1166.                   # Character '.' ⁿbergehen:
  1167.                   z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1168.                   # Version parsen:
  1169.                  {var reg3 object version = parse_logical_word(&z,FALSE);
  1170.                   if (eq(version,S(Kwild))) { }
  1171.                   elif (equal(version,Symbol_name(S(Knewest))))
  1172.                     { version = S(Knewest); }
  1173.                   elif (all_digits(version))
  1174.                     { pushSTACK(version); funcall(L(parse_integer),1); # version in Integer umwandeln
  1175.                       version = value1;
  1176.                     }
  1177.                   else
  1178.                     { version = NIL; }
  1179.                   TheLogpathname(STACK_1)->pathname_version = version;
  1180.                   if (nullp(version))
  1181.                     { z = z_type; } # Character '.' wieder zurⁿck
  1182.                 }}
  1183.                 else
  1184.                 { TheLogpathname(STACK_1)->pathname_version = NIL; }
  1185.             }
  1186.             else
  1187.             { z = z_name; # Character '.' wieder zurⁿck
  1188.               TheLogpathname(STACK_1)->pathname_version = NIL;
  1189.             }
  1190.         }}
  1191.         else
  1192.         { TheLogpathname(STACK_1)->pathname_type = NIL;
  1193.           TheLogpathname(STACK_1)->pathname_version = NIL;
  1194.         }
  1195.     }
  1196.     skipSTACK(1);
  1197.     return z.count;
  1198.   }
  1199.  
  1200. #undef slashp
  1201.  
  1202. # Erkennung eines logischen Hosts, vgl. CLtL2 S. 631
  1203. # (defun logical-host-p (host)
  1204. #   (and (simple-string-p host)
  1205. #        (gethash host sys::*logical-pathname-translations*)
  1206. #        t
  1207. # ) )
  1208.   local boolean logical_host_p (object host);
  1209.   local boolean logical_host_p(host)
  1210.     var reg1 object host;
  1211.     { return (simple_string_p(host)
  1212.               # Fehlt host = string_upcase(host); ??
  1213.               && !eq(gethash(host,Symbol_value(S(logpathname_translations))),
  1214.                      nullobj
  1215.              )      );
  1216.     }
  1217.  
  1218. #endif
  1219.  
  1220. #ifdef PATHNAME_EXT83
  1221. # Hilfsfunktion fⁿr PARSE-NAMESTRING:
  1222. # Parst einen Namens- oder Typteil.
  1223. # parse_name_or_type(&z,stdlen,def)
  1224. # > stdlen: Standard-LΣnge des Teils
  1225. # > def: Defaultwert
  1226. # > STACK_3: Datenvektor des Strings
  1227. # > z: Zustand
  1228. # < z: Zustand
  1229. # < ergebnis: Namens- oder Typteil (=default, falls leer)
  1230. # kann GC ausl÷sen
  1231.   local object parse_name_or_type (zustand* z, uintL stdlen, object def);
  1232.   local object parse_name_or_type(z,stdlen,def)
  1233.     var reg1 zustand* z;
  1234.     var reg5 uintL stdlen;
  1235.     var reg6 object def;
  1236.     { var reg3 uintL z_start_index = z->index; # Index beim Start des Namens
  1237.       loop
  1238.         { var reg2 uintB ch;
  1239.           if (z->count == 0) break;
  1240.           ch = TheSstring(STACK_3)->data[z->index]; # nΣchstes Character
  1241.           ch = up_case(ch); # als Gro▀buchstabe
  1242.           if (ch == '.') break;
  1243.           if (ch == '*')
  1244.             # '*' angetroffen.
  1245.             { # nicht am Anfang des Namens -> beendet den Namen:
  1246.               if (!(z->index == z_start_index)) break;
  1247.               # Character ⁿbergehen:
  1248.               z->index++; z->FNindex = fixnum_inc(z->FNindex,1); z->count--;
  1249.               return S(Kwild); # Name := :WILD
  1250.             }
  1251.           if (!legal_namechar(ch)) break; # gⁿltiges Character ?
  1252.           # ja -> Teil des Namens
  1253.           # Character ⁿbergehen:
  1254.           z->index++; z->FNindex = fixnum_inc(z->FNindex,1); z->count--;
  1255.         }
  1256.       # Ende des Namens erreicht.
  1257.       # Name := Teilstring von STACK_3 von z_start_index (einschlie▀lich)
  1258.       #                                bis z->index (ausschlie▀lich).
  1259.      {var reg3 uintL len = z->index - z_start_index;
  1260.       # kein Name angegeben -> default zurⁿck:
  1261.       if (len==0) { return def; }
  1262.       #ifndef EMUNIX_PORTABEL # unter OS/2 gilt die 8+3-Regel nicht mehr
  1263.       # bei len > stdlen setze len:=stdlen :
  1264.       if (len > stdlen) { len = stdlen; }
  1265.       #endif
  1266.       {var reg4 object string = allocate_string(len); # String der LΣnge len
  1267.        # fⁿllen:
  1268.        var reg1 uintB* ptr1 = &TheSstring(STACK_3)->data[z_start_index];
  1269.        var reg2 uintB* ptr2 = &TheSstring(string)->data[0];
  1270.        dotimespL(len,len, { *ptr2++ = up_case(*ptr1++); });
  1271.        # Name fertig.
  1272.        return string;
  1273.     }}}
  1274. #endif
  1275.  
  1276. #ifdef PATHNAME_NOEXT
  1277. # Hilfsfunktion fⁿr PARSE-NAMESTRING:
  1278. # Spaltet einen String (beim letzten Punkt) in Name und Typ auf.
  1279. # split_name_type(skip);
  1280. # > STACK_0: Simple-String
  1281. # > skip: 1 falls ein Punkt an erster Stelle nicht aufspaltend wirken soll, 0 sonst
  1282. # < STACK_1: Name
  1283. # < STACK_0: Typ
  1284. # Erniedrigt STACK um 1
  1285. # kann GC ausl÷sen
  1286.   local void split_name_type (uintL skip);
  1287.   local void split_name_type(skip)
  1288.     var reg2 uintL skip;
  1289.     { var reg5 object string = STACK_0;
  1290.       var reg7 uintL length = TheSstring(string)->length;
  1291.       # Nach dem letzten Punkt suchen:
  1292.       var reg4 uintL index = length;
  1293.       { var reg1 uintB* ptr = &TheSstring(string)->data[index];
  1294.         while (index>skip)
  1295.           { if (*--ptr == '.') goto punkt;
  1296.             index--;
  1297.       }   }
  1298.       # kein Punkt gefunden -> Typ := NIL
  1299.       pushSTACK(NIL);
  1300.       goto name_type_ok;
  1301.       punkt: # Punkt bei index gefunden
  1302.       { # type := (substring string index)
  1303.         var reg3 uintL count = length-index;
  1304.         var reg6 object type = allocate_string(count);
  1305.         var reg1 uintB* ptr2 = &TheSstring(type)->data[0];
  1306.         var reg2 uintB* ptr1 = &TheSstring(STACK_0)->data[index];
  1307.         dotimesL(count,count, { *ptr2++ = *ptr1++; } );
  1308.         pushSTACK(type);
  1309.       }
  1310.       { # name := (substring string 0 (1- index))
  1311.         var reg3 uintL count = index-1;
  1312.         var reg6 object name = allocate_string(count);
  1313.         var reg1 uintB* ptr2 = &TheSstring(name)->data[0];
  1314.         var reg2 uintB* ptr1 = &TheSstring(STACK_1)->data[0];
  1315.         dotimesL(count,count, { *ptr2++ = *ptr1++; } );
  1316.         STACK_1 = name;
  1317.       }
  1318.       name_type_ok: ;
  1319.     }
  1320. #endif
  1321.  
  1322. LISPFUN(parse_namestring,1,2,norest,key,3,\
  1323.         (kw(start),kw(end),kw(junk_allowed)) )
  1324. # (PARSE-NAMESTRING thing [host [defaults [:start] [:end] [:junk-allowed]]]),
  1325. # CLTL S. 414
  1326.   { # Stackaufbau: thing, host, defaults, start, end, junk-allowed.
  1327.     var reg6 boolean junk_allowed;
  1328.     var reg7 boolean parse_logical = FALSE;
  1329.     # 1. junk-allowed ⁿberprⁿfen:
  1330.     { var reg1 object obj = popSTACK(); # junk-allowed-Argument
  1331.       if (eq(obj,unbound))
  1332.         { junk_allowed = FALSE; }
  1333.         else
  1334.         if (nullp(obj)) { junk_allowed = FALSE; } else { junk_allowed = TRUE; }
  1335.     }
  1336.     # Stackaufbau: thing, host, defaults, start, end.
  1337.     # 2. Default-Wert fⁿr start ist 0:
  1338.     { if (eq(STACK_1,unbound)) { STACK_1 = Fixnum_0; }}
  1339.     # 3. host ⁿberprⁿfen:
  1340.     #if HAS_HOST || defined(LOGICAL_PATHNAMES)
  1341.     { var reg2 object host;
  1342.       #if HAS_HOST
  1343.       host = test_optional_host(STACK_3,FALSE);
  1344.       #else
  1345.       host = test_optional_host(STACK_3);
  1346.       #endif
  1347.       if (nullp(host))
  1348.         { # host := (PATHNAME-HOST defaults)
  1349.           var reg1 object defaults = test_default_pathname(STACK_2);
  1350.           #ifdef LOGICAL_PATHNAMES
  1351.           if (logpathnamep(defaults))
  1352.             { parse_logical = TRUE; host = TheLogpathname(defaults)->pathname_host; }
  1353.             else
  1354.           #endif
  1355.             {
  1356.               #if HAS_HOST
  1357.               host = ThePathname(defaults)->pathname_host;
  1358.               #else
  1359.               host = NIL;
  1360.               #endif
  1361.             }
  1362.         }
  1363.       #ifdef LOGICAL_PATHNAMES
  1364.       elif (logical_host_p(host))
  1365.         { parse_logical = TRUE; host = string_upcase(host); }
  1366.       #endif
  1367.       STACK_3 = host;
  1368.     }
  1369.     #else
  1370.     { test_optional_host(STACK_3); }
  1371.     #endif
  1372.     # 4. thing mu▀ ein String sein:
  1373.     { var reg5 object thing = STACK_4;
  1374.       if (xpathnamep(thing)) # Pathname?
  1375.         { value1 = thing; # 1. Wert thing
  1376.           fertig:
  1377.           value2 = STACK_1; mv_count=2; # 2. Wert start
  1378.           skipSTACK(5); return;
  1379.         }
  1380.       if (streamp(thing)) # Stream?
  1381.         { thing = as_file_stream(thing);
  1382.           value1 = TheStream(thing)->strm_file_name; # 1. Wert: Filename
  1383.           goto fertig; # 2. Wert wie oben
  1384.         }
  1385.       # thing sollte nun wenigstens ein String oder Symbol sein:
  1386.       if (!stringp(thing))
  1387.         { if (!symbolp(thing)) { fehler_thing(thing); }
  1388.           thing = Symbol_name(thing); # Symbol -> Symbolname verwenden
  1389.           if (!parse_logical)
  1390.             {
  1391.               #if defined(PATHNAME_UNIX) || defined(PATHNAME_OS2) || defined(PATHNAME_RISCOS)
  1392.               # Betriebssystem mit Vorzug fⁿr Kleinbuchstaben
  1393.               thing = copy_string(thing); # ja -> mit STRING-DOWNCASE umwandeln
  1394.               nstring_downcase(&TheSstring(thing)->data[0],TheSstring(thing)->length);
  1395.               #endif
  1396.               #ifdef PATHNAME_AMIGAOS
  1397.               # Betriebssystem mit Vorzug fⁿr Capitalize
  1398.               thing = copy_string(thing); # ja -> mit STRING-CAPITALIZE umwandeln
  1399.               nstring_capitalize(&TheSstring(thing)->data[0],TheSstring(thing)->length);
  1400.               #endif
  1401.             }
  1402.           STACK_4 = thing; # und in den Stack zurⁿckschreiben
  1403.         }
  1404.       # thing = STACK_4 ist jetzt ein String.
  1405.       { # Er wird durchlaufen.
  1406.         var zustand z; # laufender Zustand
  1407.         #ifdef PATHNAME_RISCOS
  1408.         # Hilfsvariablen zur Umsetzung eines new_thing-relativen FNindex
  1409.         # in einen thing-relativen FNindex.
  1410.         var object FNindex_limit = Fixnum_0;
  1411.         var sintL FNindex_offset = 0;
  1412.         var object FNindex_fallback;
  1413.         #endif
  1414.        {var object string; # String thing
  1415.         # Grenzen ⁿberprⁿfen, mit thing, start, end als Argumenten:
  1416.         pushSTACK(thing); pushSTACK(STACK_(1+1)); pushSTACK(STACK_(0+2));
  1417.         test_string_limits(&string,&z.index,&z.count);
  1418.         # z.index = Wert des start-Arguments,
  1419.         # z.count = Anzahl der Characters.
  1420.         z.FNindex = fixnum(z.index);
  1421.         # z.FNindex = start-Index als Fixnum.
  1422.         string = array_displace_check(string,z.count,&z.index); # Datenvektor holen,
  1423.         # z.index = Offset + Startindex = Startoffset
  1424.         pushSTACK(string);
  1425.        }
  1426.         #ifdef LOGICAL_PATHNAMES
  1427.         if (parse_logical)
  1428.           { pushSTACK(allocate_logpathname());
  1429.             # Stackaufbau: ..., Datenvektor, Pathname.
  1430.            {var reg1 uintL remaining = parse_logical_pathnamestring(z);
  1431.             z.index += z.count-remaining; z.FNindex = fixnum_inc(z.FNindex,z.count-remaining); z.count = remaining;
  1432.           }}
  1433.           else
  1434.         #endif
  1435.           {
  1436.             #ifdef PATHNAME_RISCOS
  1437.               # If the string starts with a system variable in <...> syntax,
  1438.               # then perform the substitution
  1439.               # (string-concat "<" var ">" tail) --> (string-concat (sys::getenv var) tail).
  1440.               if ((!(z.count==0)) && (TheSstring(STACK_0)->data[z.index] == '<'))
  1441.                 { var zustand startz = z; # Start-Zustand
  1442.                   var reg1 uintB ch;
  1443.                   # Character '<' ⁿbergehen:
  1444.                   z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1445.                   loop
  1446.                     { if (z.count==0) goto no_envvar;
  1447.                       ch = TheSstring(STACK_0)->data[z.index]; # nΣchstes Character
  1448.                       if (ch=='>') break;
  1449.                       if (!(graphic_char_p(ch) && !(ch=='*') && !(ch=='#'))) goto no_envvar;
  1450.                       # gⁿltiges Character ⁿbergehen:
  1451.                       z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1452.                     }
  1453.                   FNindex_fallback = z.FNindex;
  1454.                   # Character '>' ⁿbergehen:
  1455.                   z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1456.                   # Environment-Variable als ASCIZ-String bauen:
  1457.                  {var reg4 object envvar;
  1458.                   { var reg3 uintL len = z.index - startz.index - 2;
  1459.                     if (len==0) goto no_envvar;
  1460.                     envvar = allocate_string(len+1);
  1461.                     # und fⁿllen:
  1462.                    {var reg2 uintB* ptr1 = &TheSstring(STACK_0)->data[startz.index+1];
  1463.                     var reg1 uintB* ptr2 = &TheSstring(envvar)->data[0];
  1464.                     dotimesL(len,len, { *ptr2++ = *ptr1++; });
  1465.                     *ptr2 = '\0';
  1466.                   }}
  1467.                   # Dessen Wert holen:
  1468.                    begin_system_call();
  1469.                   {var reg1 const char* envval = getenv(TheAsciz(envvar));
  1470.                    end_system_call();
  1471.                    if (envval==NULL)
  1472.                      { pushSTACK(envvar);
  1473.                        pushSTACK(S(parse_namestring));
  1474.                        fehler(error,
  1475.                               DEUTSCH ? "~: Es gibt keine Environment-Variable ~." :
  1476.                               ENGLISH ? "~: there is no environment variable ~" :
  1477.                               FRANCAIS ? "~ : Il n'y a pas de variable ~ dans l'environnement." :
  1478.                               ""
  1479.                              );
  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_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  1593.               # Einbuchstabige Device-Specification und evtl. Seriennummer parsen:
  1594.               {var reg3 object device = NIL; # Device := NIL
  1595.                #if HAS_SERNR
  1596.                var reg4 object seriennummer = NIL; # Seriennummer := NIL
  1597.                #endif
  1598.                # Drive-Specification parsen:
  1599.                # Kommt evtl. ein Buchstabe ('*','A'-'Z','a'-'z'), evtl. eine
  1600.                # Seriennummer (Integer >=0, <2^24) und dann ein ':' ?
  1601.                { var zustand startz = z; # Start-Zustand
  1602.                  var reg1 uintB ch;
  1603.                  if (z.count==0) goto no_drivespec; # String schon zu Ende ?
  1604.                  ch = TheSstring(STACK_1)->data[z.index]; # nΣchstes Character
  1605.                  ch = up_case(ch); # als Gro▀buchstabe
  1606.                  if (ch == '*')
  1607.                    # ch = '*' -> Device := :WILD
  1608.                    { device = S(Kwild); }
  1609.                  elif ((ch >= 'A') && (ch <= 'Z'))
  1610.                    # 'A' <= ch <= 'Z' -> Device := "ch"
  1611.                    { var reg1 object string = allocate_string(1); # String der LΣnge 1
  1612.                      TheSstring(string)->data[0] = ch; # mit ch als einzigem Buchstaben
  1613.                      device = string;
  1614.                    }
  1615.                  else goto no_device;
  1616.                  # Device OK, Character ⁿbergehen:
  1617.                  z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1618.                  if (z.count==0) goto no_drivespec; # String schon zu Ende ?
  1619.                  ch = TheSstring(STACK_1)->data[z.index]; # nΣchstes Character
  1620.                  ch = up_case(ch); # als Gro▀buchstabe
  1621.                  no_device:
  1622.                  #if HAS_SERNR
  1623.                  # Kommt eventuell eine Seriennummer ?
  1624.                  if ((ch >= '0') && (ch <= '9'))
  1625.                    { # ja.
  1626.                      var reg2 uintL akku = 0; # Hilfsregister zum Aufbau der Seriennummer
  1627.                      loop
  1628.                        { ch = ch - '0'; # Wert der Ziffer
  1629.                          akku = 10*akku+ch; # Seriennummer um eine Ziffer erweitern
  1630.                          if (akku > (uintL)(bitm(oint_data_len)-1))
  1631.                            goto no_drivespec; # >=2^24 geworden -> ist wohl keine Seriennummer
  1632.                          # Character ⁿbergehen:
  1633.                          z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1634.                          if (z.count==0) goto no_drivespec; # String schon zu Ende ?
  1635.                          ch = TheSstring(STACK_1)->data[z.index]; # nΣchstes Character
  1636.                          ch = up_case(ch); # als Gro▀buchstabe
  1637.                          # noch eine Ziffer -> zΣhlt zur Seriennummer
  1638.                          if (!((ch >= '0') && (ch <= '9'))) break;
  1639.                        }
  1640.                      # Seriennummer zu Ende
  1641.                      seriennummer = fixnum(akku); # akku als Fixnum
  1642.                    }
  1643.                  #endif
  1644.                  # mit Doppelpunkt abgeschlossen?
  1645.                  if (!(ch == ':')) goto no_drivespec;
  1646.                  # Character ⁿbergehen:
  1647.                  z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1648.                  goto drivespec_ok;
  1649.                  no_drivespec:
  1650.                  # Es ist nicht gelungen, eine Drive-Specification zu parsen.
  1651.                  z = startz; # Start-Zustand wiederherstellen
  1652.                  device = NIL; # Device := NIL
  1653.                  #if HAS_SERNR
  1654.                  seriennummer = NIL; # Seriennummer := NIL
  1655.                  #endif
  1656.                }
  1657.                drivespec_ok:
  1658.                ThePathname(STACK_0)->pathname_device = device; # Device eintragen
  1659.                #if HAS_SERNR
  1660.                if (!NIL_IS_CONSTANT) { pushSTACK(seriennummer); } # Seriennummer retten (kann NIL oder ein Fixnum sein)
  1661.                { var reg1 object new_cons = allocate_cons(); # neues Cons
  1662.                  if (!NIL_IS_CONSTANT) { seriennummer = popSTACK(); } # Seriennummer zurⁿck
  1663.                  Car(new_cons) = seriennummer; # = (cons Seriennummer NIL)
  1664.                  ThePathname(STACK_0)->pathname_directory = new_cons;
  1665.                  pushSTACK(new_cons);
  1666.                  new_cons = allocate_cons(); # neues Cons fⁿr Startpoint
  1667.                  Cdr(STACK_0) = new_cons; # verlΣngert (pathname-directory Pathname)
  1668.                  STACK_0 = new_cons; # neues (last (pathname-directory Pathname))
  1669.                }
  1670.                #define HAVE_Startpoint_Cons
  1671.                #endif
  1672.               }
  1673.              #endif
  1674.              #ifdef PATHNAME_AMIGAOS
  1675.               # Device-Specification parsen:
  1676.               {var reg3 object device;
  1677.                # Kommt eine nichtleere Folge von alphanumerischen Zeichen und dann ein ':' ?
  1678.                { var zustand startz = z; # Start-Zustand
  1679.                  var reg1 uintB ch;
  1680.                  loop
  1681.                    { if (z.count==0) goto no_devicespec; # String schon zu Ende -> kein Device
  1682.                      ch = TheSstring(STACK_1)->data[z.index]; # nΣchstes Character
  1683.                      if (!legal_namechar(ch)) break;
  1684.                      # alphanumerisches Character ⁿbergehen:
  1685.                      z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1686.                    }
  1687.                  if (!(ch==':')) goto no_devicespec; # kein ':' -> kein Device
  1688.                  if (z.index==startz.index) goto no_devicespec; # ':' am Anfang ist kein Device
  1689.                  # Device-String bilden:
  1690.                  { var reg4 uintL len = z.index - startz.index;
  1691.                    device = allocate_string(len);
  1692.                    # und fⁿllen:
  1693.                   {var reg2 uintB* ptr1 = &TheSstring(STACK_1)->data[startz.index];
  1694.                    var reg3 uintB* ptr2 = &TheSstring(device)->data[0];
  1695.                    dotimesL(len,len, { *ptr2++ = *ptr1++; });
  1696.                  }}
  1697.                  # Character ':' nicht ⁿbergehen; das ergibt dann :ABSOLUTE.
  1698.                  goto devicespec_ok;
  1699.                  no_devicespec: # keine Device-Specification
  1700.                    z = startz; # zum Start zurⁿck
  1701.                    device = NIL; # Device NIL
  1702.                }
  1703.                devicespec_ok:
  1704.                # Device eintragen:
  1705.                ThePathname(STACK_0)->pathname_device = device;
  1706.               }
  1707.              #endif
  1708.              #ifdef PATHNAME_RISCOS
  1709.               # Device-Specification parsen:
  1710.               {var reg3 object device;
  1711.                # Kommt ein ':', eine nichtleere Folge von Zeichen und dann ein '.' ?
  1712.                { var zustand startz = z; # Start-Zustand
  1713.                  var reg1 uintB ch;
  1714.                  if (z.count==0) goto no_devicespec; # String schon zu Ende -> kein Device
  1715.                  ch = TheSstring(STACK_1)->data[z.index]; # nΣchstes Character
  1716.                  if (!(ch==':')) goto no_devicespec; # kein ':' -> kein Device
  1717.                  # Character ':' ⁿbergehen:
  1718.                  z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1719.                  loop
  1720.                    { if (z.count==0) goto no_devicespec; # String schon zu Ende -> kein Device
  1721.                      ch = TheSstring(STACK_1)->data[z.index]; # nΣchstes Character
  1722.                      if (!(legal_namechar(ch) && !(ch=='*') && !singlewild_char_p(ch))) break;
  1723.                      # gⁿltiges Character ⁿbergehen:
  1724.                      z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1725.                    }
  1726.                  if (!(ch=='.')) goto no_devicespec; # kein '.' -> kein Device
  1727.                  # Device-String bilden:
  1728.                  { var reg4 uintL len = z.index - startz.index - 1;
  1729.                    if (len==0) goto no_devicespec;
  1730.                    device = allocate_string(len);
  1731.                    # und fⁿllen:
  1732.                   {var reg2 uintB* ptr1 = &TheSstring(STACK_1)->data[startz.index+1];
  1733.                    var reg3 uintB* ptr2 = &TheSstring(device)->data[0];
  1734.                    dotimesL(len,len, { *ptr2++ = *ptr1++; });
  1735.                  }}
  1736.                  # Character '.' ⁿbergehen:
  1737.                  z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1738.                  goto devicespec_ok;
  1739.                  no_devicespec: # keine Device-Specification
  1740.                    z = startz; # zum Start zurⁿck
  1741.                    device = NIL; # Device NIL
  1742.                }
  1743.                devicespec_ok:
  1744.                # Device eintragen:
  1745.                ThePathname(STACK_0)->pathname_device = device;
  1746.               }
  1747.              #endif
  1748.             #endif
  1749.             #ifndef HAVE_Startpoint_Cons # falls nicht oben schon erledigt
  1750.             # Directory-Start eintragen:
  1751.             { var reg1 object new_cons = allocate_cons(); # neues Cons fⁿr Startpoint
  1752.               ThePathname(STACK_0)->pathname_directory = new_cons;
  1753.               pushSTACK(new_cons); # neues (last (pathname-directory Pathname))
  1754.             }
  1755.             #endif
  1756.             # Stackaufbau: ..., Datenvektor, Pathname, (last (pathname-directory Pathname)).
  1757.             # Subdirectories parsen:
  1758.             # Trennzeichen zwischen subdirs ist unter MSDOS sowohl '\' als auch '/':
  1759.             #ifdef PATHNAME_ATARI
  1760.              #define slashp(c)  ((c) == '\\')
  1761.             #endif
  1762.             #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  1763.              #define slashp(c)  (((c) == '\\') || ((c) == '/'))
  1764.             #endif
  1765.             #if defined(PATHNAME_UNIX) || defined(PATHNAME_AMIGAOS)
  1766.              #define slashp(c)  ((c) == '/')
  1767.             #endif
  1768.             #ifdef PATHNAME_RISCOS
  1769.              #define slashp(c)  ((c) == '.')
  1770.             #endif
  1771.             {
  1772.               #if defined(USER_HOMEDIR) && defined(PATHNAME_UNIX)
  1773.               # Falls sofort ein '~' kommt, wird bis zum nΣchsten '/' oder Stringende
  1774.               # ein Username gelesen und das Home-Directory dieses Users eingesetzt:
  1775.               if ((!(z.count == 0)) && (TheSstring(STACK_2)->data[z.index] == '~'))
  1776.                 # Es kommt sofort ein '~'.
  1777.                 { # Character ⁿbergehen:
  1778.                   z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1779.                  {var reg6 object userhomedir; # Pathname des User-Homedir
  1780.                   # nΣchsten '/' suchen:
  1781.                   var reg2 uintB* charptr = &TheSstring(STACK_2)->data[z.index];
  1782.                   var reg3 uintL charcount = 0;
  1783.                   { var reg4 uintL count;
  1784.                     dotimesL(count,z.count,
  1785.                       { if (*charptr++ == '/') break;
  1786.                         charcount++;
  1787.                       });
  1788.                   }
  1789.                   # Username hat charcount Zeichen
  1790.                   if (charcount==0)
  1791.                     { userhomedir = O(user_homedir); } # nur '~' -> User-Homedir
  1792.                     else
  1793.                     { # Username als ASCIZ-String bauen:
  1794.                       var reg5 object username = allocate_string(charcount+1);
  1795.                       { var reg1 uintB* charptr2 = &TheSstring(username)->data[0];
  1796.                         var reg4 uintL count;
  1797.                         charptr = &TheSstring(STACK_2)->data[z.index];
  1798.                         dotimespL(count,charcount, { *charptr2++ = *charptr++; } );
  1799.                         *charptr2 = '\0';
  1800.                       }
  1801.                       # Dessen Home-Directory aus dem Passwort-File holen:
  1802.                       begin_system_call();
  1803.                       errno = 0;
  1804.                      {var reg1 struct passwd * userpasswd = getpwnam(TheAsciz(username));
  1805.                       end_system_call();
  1806.                       if (userpasswd == (struct passwd *)NULL) # erfolglos?
  1807.                         { if (!(errno==0)) { OS_error(); } # Error melden
  1808.                           # sonst: Fehler
  1809.                           pushSTACK(username);
  1810.                           pushSTACK(S(parse_namestring));
  1811.                           fehler(error,
  1812.                                  DEUTSCH ? "~: Es gibt keinen Benutzer mit Namen ~." :
  1813.                                  ENGLISH ? "~: there is no user named ~" :
  1814.                                  FRANCAIS ? "~ : Il n'y a pas d'utilisateur de nom ~." :
  1815.                                  ""
  1816.                                 );
  1817.                         }
  1818.                       userhomedir = asciz_dir_to_pathname(userpasswd->pw_dir); # Homedir als Pathname
  1819.                     }}
  1820.                   # Directory aus dem Pathname userhomedir kopieren:
  1821.                   # (copy-list dir) = (nreconc (reverse dir) nil),
  1822.                   # dabei dessen letztes Cons merken.
  1823.                   userhomedir = reverse(ThePathname(userhomedir)->pathname_directory);
  1824.                   STACK_0 = userhomedir; userhomedir = nreconc(userhomedir,NIL);
  1825.                   ThePathname(STACK_1)->pathname_directory = userhomedir;
  1826.                   # username-Characters ⁿbergehen:
  1827.                   z.index += charcount; z.FNindex = fixnum_inc(z.FNindex,charcount); z.count -= charcount;
  1828.                   # Falls der String zu Ende ist: fertig,
  1829.                   # sonst kommt sofort ein '/', es wird ⁿbergangen:
  1830.                   if (z.count==0)
  1831.                     { pushSTACK(NIL); pushSTACK(NIL); goto after_name_type; } # Name und Typ := NIL
  1832.                   # Character ⁿbergehen:
  1833.                   z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1834.                 }}
  1835.               else
  1836.               #endif
  1837.               #if defined(PATHNAME_UNIX) && 0 # Wozu braucht man das, au▀er fⁿr $HOME ?
  1838.               # Falls sofort ein '$' kommt, wird bis zum nΣchsten '/' oder Stringende
  1839.               # eine Environment-Variable gelesen und ihr Wert eingesetzt:
  1840.               if ((!(z.count == 0)) && (TheSstring(STACK_2)->data[z.index] == '$'))
  1841.                 # Es kommt sofort ein '$'.
  1842.                 { # Character ⁿbergehen:
  1843.                   z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1844.                  {var reg6 object envval_dir;
  1845.                   # nΣchsten '/' suchen:
  1846.                   var reg2 uintB* charptr = &TheSstring(STACK_2)->data[z.index];
  1847.                   var reg3 uintL charcount = 0;
  1848.                   { var reg4 uintL count;
  1849.                     dotimesL(count,z.count,
  1850.                       { if (*charptr++ == '/') break;
  1851.                         charcount++;
  1852.                       });
  1853.                   }
  1854.                   # Environment-Variable hat charcount Zeichen,
  1855.                   # als ASCIZ-String bauen:
  1856.                   { var reg5 object envvar = allocate_string(charcount+1);
  1857.                     { var reg1 uintB* charptr2 = &TheSstring(envvar)->data[0];
  1858.                       var reg4 uintL count;
  1859.                       charptr = &TheSstring(STACK_2)->data[z.index];
  1860.                       dotimesL(count,charcount, { *charptr2++ = *charptr++; } );
  1861.                       *charptr2 = '\0';
  1862.                     }
  1863.                     # Dessen Wert holen:
  1864.                     begin_system_call();
  1865.                    {var reg1 const char* envval = getenv(TheAsciz(envvar));
  1866.                     end_system_call();
  1867.                     if (envval==NULL)
  1868.                       { pushSTACK(envvar);
  1869.                         pushSTACK(S(parse_namestring));
  1870.                         fehler(error,
  1871.                                DEUTSCH ? "~: Es gibt keine Environment-Variable ~." :
  1872.                                ENGLISH ? "~: there is no environment variable ~" :
  1873.                                FRANCAIS ? "~ : Il n'y a pas de variable ~ dans l'environnement." :
  1874.                                ""
  1875.                               );
  1876.                       }
  1877.                     envval_dir = asciz_dir_to_pathname(envval); # Wert der Variablen als Pathname
  1878.                   }}
  1879.                   # Directory aus dem Pathname envval_dir kopieren:
  1880.                   # (copy-list dir) = (nreconc (reverse dir) nil),
  1881.                   # dabei dessen letztes Cons merken.
  1882.                   envval_dir = reverse(ThePathname(envval_dir)->pathname_directory);
  1883.                   STACK_0 = envval_dir; envval_dir = nreconc(envval_dir,NIL);
  1884.                   ThePathname(STACK_1)->pathname_directory = envval_dir;
  1885.                   # envvar-Characters ⁿbergehen:
  1886.                   z.index += charcount; z.FNindex = fixnum_inc(z.FNindex,charcount); z.count -= charcount;
  1887.                   # Falls der String zu Ende ist: fertig,
  1888.                   # sonst kommt sofort ein '/', es wird ⁿbergangen:
  1889.                   if (z.count==0)
  1890.                     { pushSTACK(NIL); pushSTACK(NIL); goto after_name_type; } # Name und Typ := NIL
  1891.                   # Character ⁿbergehen:
  1892.                   z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1893.                 }}
  1894.               else
  1895.               #endif
  1896.               #if defined(PATHNAME_UNIX) || defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  1897.               # Falls sofort ein '\' bzw. '/' kommt, wird er ⁿbergangen, und es kommt
  1898.               # :ABSOLUTE (sonst :RELATIVE) als erstes subdir:
  1899.               if ((!(z.count == 0)) && slashp(TheSstring(STACK_2)->data[z.index]))
  1900.                 # Es kommt sofort ein '\' bzw. '/'.
  1901.                 { # Character ⁿbergehen:
  1902.                   z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1903.                   Car(STACK_0) = S(Kabsolute); # Startpoint = :ABSOLUTE
  1904.                 }
  1905.                 else
  1906.                 # Es kommt nicht sofort ein '\' bzw. '/'.
  1907.                 { Car(STACK_0) = S(Krelative); } # Startpoint = :RELATIVE
  1908.               #endif
  1909.               #ifdef PATHNAME_AMIGAOS
  1910.               # Falls sofort ein ':' kommt, wird er ⁿbergangen, und es kommt
  1911.               # :ABSOLUTE (sonst :RELATIVE) als erstes subdir:
  1912.               if ((!(z.count == 0)) && (TheSstring(STACK_2)->data[z.index] == ':'))
  1913.                 # Es kommt sofort ein ':'.
  1914.                 { # Character ⁿbergehen:
  1915.                   z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1916.                   Car(STACK_0) = S(Kabsolute); # directory = (:ABSOLUTE)
  1917.                 }
  1918.                 else
  1919.                 # Es kommt nicht sofort ein ':'.
  1920.                 { Car(STACK_0) = S(Krelative); } # directory = (:RELATIVE)
  1921.               #endif
  1922.               #ifdef PATHNAME_RISCOS
  1923.               # PrΣfix '$.' oder '&.' oder '@.' oder '%.' oder '\.' parsen.
  1924.               if ((z.count >= 2) && (TheSstring(STACK_2)->data[z.index+1] == '.'))
  1925.                 { switch (TheSstring(STACK_2)->data[z.index])
  1926.                     { case '$': Car(STACK_0) = S(Kroot); break; # directory = (:ABSOLUTE :ROOT)
  1927.                       case '&': Car(STACK_0) = S(Khome); break; # directory = (:ABSOLUTE :HOME)
  1928.                       case '@': Car(STACK_0) = S(Kcurrent); break; # directory = (:ABSOLUTE :CURRENT)
  1929.                       case '%': Car(STACK_0) = S(Klibrary); break; # directory = (:ABSOLUTE :LIBRARY)
  1930.                       case '\\': Car(STACK_0) = S(Kprevious); break; # directory = (:ABSOLUTE :PREVIOUS)
  1931.                       default: goto prefix_relative;
  1932.                     }
  1933.                   # PrΣfix ⁿbergehen:
  1934.                   z.index+=2; z.FNindex = fixnum_inc(z.FNindex,2); z.count-=2;
  1935.                   # (pathname-directory pathname) um ein Cons (:ABSOLUTE) verlΣngern:
  1936.                  {var reg1 object new_cons = allocate_cons(); # neues Cons
  1937.                   Car(new_cons) = S(Kabsolute); Cdr(new_cons) = STACK_0;
  1938.                   ThePathname(STACK_1)->pathname_directory = new_cons;
  1939.                 }}
  1940.                 else
  1941.                 prefix_relative:
  1942.                 { Car(STACK_0) = S(Krelative); } # directory = (:RELATIVE)
  1943.               #endif
  1944.               #if !defined(PATHNAME_RISCOS)
  1945.               loop
  1946.                 { # Versuche, ein weiteres Unterdirectory zu parsen.
  1947.                   #ifdef PATHNAME_EXT83
  1948.                     # Kommt '.\' oder '..\' oder '...\' ?
  1949.                     if ((!(z.count == 0)) && (TheSstring(STACK_2)->data[z.index] == '.'))
  1950.                       { # nΣchstes Character ist ein '.'.
  1951.                         var zustand subdirz = z; # Zustand beim Start des Subdirectories
  1952.                         # Character ⁿbergehen:
  1953.                         z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1954.                         if (z.count == 0) goto no_dots; # String schon zu Ende ?
  1955.                        {var reg1 uintB ch = TheSstring(STACK_2)->data[z.index]; # nΣchstes Character
  1956.                         if (slashp(ch))
  1957.                           # '.\' angetroffen -> (cons :CURRENT NIL) bauen
  1958.                           { pushSTACK(S(Kcurrent)); goto dots; }
  1959.                         if (!(ch == '.')) goto no_dots;
  1960.                         # zweites Character war auch ein '.'.
  1961.                         # Character ⁿbergehen:
  1962.                         z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1963.                         if (z.count == 0) goto no_dots; # String schon zu Ende ?
  1964.                         ch = TheSstring(STACK_2)->data[z.index]; # nΣchstes Character
  1965.                         if (slashp(ch))
  1966.                           # '..\' angetroffen -> (cons :PARENT NIL) bauen
  1967.                           { pushSTACK(S(Kparent)); goto dots; }
  1968.                         if (!(ch == '.')) goto no_dots;
  1969.                         # drittes Character war auch ein '.'.
  1970.                         # Character ⁿbergehen:
  1971.                         z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1972.                         if (z.count == 0) goto no_dots; # String schon zu Ende ?
  1973.                         ch = TheSstring(STACK_2)->data[z.index]; # nΣchstes Character
  1974.                         if (slashp(ch))
  1975.                           # '...\' angetroffen -> (cons :WILD-INFERIORS NIL) bauen
  1976.                           { pushSTACK(S(Kwild_inferiors)); goto dots; }
  1977.                         goto no_dots;
  1978.                        }
  1979.                         dots:
  1980.                         # '.\' oder '..\' oder '...\' angetroffen, Keyword im Stack.
  1981.                         # Character '\' ⁿbergehen:
  1982.                         z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1983.                         goto subdir_ok;
  1984.                         no_dots:
  1985.                         z = subdirz; # Zustand wiederherstellen
  1986.                       }
  1987.                     # Versuche, normale 'name.typ'-Syntax zu parsen:
  1988.                     pushSTACK(NIL); # dummy
  1989.                     { # Name, hat max. 8 Buchstaben:
  1990.                       var reg1 object name = parse_name_or_type(&z,8,NIL);
  1991.                       STACK_0 = name;
  1992.                     }
  1993.                     # Versuche, '.typ'-Syntax zu parsen:
  1994.                     { var reg1 object type;
  1995.                       if ((!(z.count==0)) && (TheSstring(STACK_3)->data[z.index] == '.'))
  1996.                         { # Es kommt ein '.'. Character ⁿbergehen:
  1997.                           z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  1998.                           # Typ, hat max. 3 Buchstaben:
  1999.                           type = parse_name_or_type(&z,3,O(leer_string));
  2000.                         }
  2001.                         else
  2002.                         { type = NIL; }
  2003.                       pushSTACK(type);
  2004.                     }
  2005.                     # Stackaufbau: ...,
  2006.                     #   Datenvektor, Pathname, (last (pathname-directory Pathname)),
  2007.                     #   name, type.
  2008.                     # Kommt sofort ein '\', so war es ein Unterdirectory,
  2009.                     # sonst ist der Pathname beendet:
  2010.                     if ((z.count==0) || !slashp(TheSstring(STACK_4)->data[z.index])) break;
  2011.                     # Es kommt ein '\'. Character ⁿbergehen:
  2012.                     z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  2013.                     # name=NIL -> durch "" ersetzen:
  2014.                     if (eq(STACK_1,NIL)) { STACK_1 = O(leer_string); }
  2015.                     # type=NIL -> durch "" ersetzen:
  2016.                     if (eq(STACK_0,NIL)) { STACK_0 = O(leer_string); }
  2017.                     { var reg1 object new_cons = allocate_cons(); # neues Cons
  2018.                       Cdr(new_cons) = popSTACK(); # type
  2019.                       Car(new_cons) = popSTACK(); # name
  2020.                       # new_cons = (cons name type)
  2021.                       pushSTACK(new_cons);
  2022.                     }
  2023.                     subdir_ok:
  2024.                   #endif
  2025.                   #ifdef PATHNAME_NOEXT
  2026.                     { var reg3 uintL z_start_index = z.index; # Index beim Start
  2027.                       loop
  2028.                         { var reg2 uintB ch;
  2029.                           if (z.count == 0) break;
  2030.                           ch = TheSstring(STACK_2)->data[z.index]; # nΣchstes Character
  2031.                           if (!legal_namechar(ch)) break; # gⁿltiges Character ?
  2032.                           # ja -> Teil des Namens
  2033.                           # Character ⁿbergehen:
  2034.                           z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  2035.                         }
  2036.                       # Ende des Namens erreicht.
  2037.                       # Name := Teilstring von STACK_2 von z_start_index (einschlie▀lich)
  2038.                       #                                bis z.index (ausschlie▀lich).
  2039.                      {var reg3 uintL len = z.index - z_start_index;
  2040.                       var reg4 object string = allocate_string(len); # String der LΣnge len
  2041.                       # fⁿllen:
  2042.                       var reg1 uintB* ptr1 = &TheSstring(STACK_2)->data[z_start_index];
  2043.                       var reg2 uintB* ptr2 = &TheSstring(string)->data[0];
  2044.                       dotimesL(len,len, { *ptr2++ = *ptr1++; });
  2045.                       # Name fertig.
  2046.                       pushSTACK(string);
  2047.                     }}
  2048.                     # Kommt sofort ein '/' bzw. '\', so war es ein Unterdirectory,
  2049.                     # sonst ist der Pathname beendet:
  2050.                     if ((z.count==0) || !slashp(TheSstring(STACK_3)->data[z.index]))
  2051.                       # Nein -> war der Name und kein Subdir.
  2052.                       break;
  2053.                     # Es kommt ein '/' bzw. '\'. Character ⁿbergehen:
  2054.                     z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  2055.                     # Stackaufbau: ...,
  2056.                     #   Datenvektor, Pathname, (last (pathname-directory Pathname)),
  2057.                     #   subdir.
  2058.                     #ifdef PATHNAME_AMIGAOS
  2059.                     # War es '' ?
  2060.                     if (equal(STACK_0,O(leer_string)))
  2061.                       { STACK_0 = S(Kparent); } # ja -> durch :PARENT ersetzen
  2062.                     else
  2063.                     #endif
  2064.                     # War es '**' oder '...' ?
  2065.                     if (equal(STACK_0,O(wildwild_string)) || equal(STACK_0,O(punktpunktpunkt_string)))
  2066.                       { STACK_0 = S(Kwild_inferiors); } # ja -> durch :WILD-INFERIORS ersetzen
  2067.                   #endif
  2068.                   # (pathname-directory pathname) um Subdir STACK_0 verlΣngern:
  2069.                   { var reg1 object new_cons = allocate_cons(); # neues Cons
  2070.                     Car(new_cons) = popSTACK(); # = (cons subdir NIL)
  2071.                     Cdr(STACK_0) = new_cons; # verlΣngert (pathname-directory Pathname)
  2072.                     STACK_0 = new_cons; # neues (last (pathname-directory Pathname))
  2073.                   }
  2074.                 }
  2075.               #else # defined(PATHNAME_RISCOS)
  2076.               pushSTACK(unbound); # maybe-name
  2077.               # Stackaufbau: ..., Datenvektor, Pathname, (last (pathname-directory Pathname)),
  2078.               #              maybe-name.
  2079.               loop
  2080.                 { # Versuche, ein weiteres Unterdirectory zu parsen.
  2081.                   # Maybe-Name = die letzte gelesene Komponente in
  2082.                   # { { legal-wild char }+ | empty } '.'  Syntax.
  2083.                   # Ob ein weiteres subdir oder der Name, wird sich erst noch
  2084.                   # entscheiden.
  2085.                   # Kommt '^.' ?
  2086.                   if (!nullp(STACK_0)
  2087.                       && (z.count >= 2)
  2088.                       && (TheSstring(STACK_3)->data[z.index] == '^')
  2089.                       && slashp(TheSstring(STACK_3)->data[z.index+1])
  2090.                      )
  2091.                     { # beide Characters ⁿbergehen:
  2092.                       z.index+=2; z.FNindex = fixnum_inc(z.FNindex,2); z.count-=2;
  2093.                       pushSTACK(S(Kparent)); # :PARENT
  2094.                     }
  2095.                     else
  2096.                     # Versuche, normale  { legal-wild char }+  Syntax zu parsen:
  2097.                     { var reg3 uintL z_start_index = z.index; # Index beim Start des Namens
  2098.                       loop
  2099.                         { var reg2 uintB ch;
  2100.                           if (z.count == 0) break;
  2101.                           ch = TheSstring(STACK_3)->data[z.index]; # nΣchstes Character
  2102.                           if (!legal_namechar(ch)) break; # gⁿltiges Character ?
  2103.                           # ja -> Teil des Namens
  2104.                           # Character ⁿbergehen:
  2105.                           z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  2106.                         }
  2107.                       # Ende des Namens erreicht.
  2108.                       # Name := Teilstring von STACK_3 von z_start_index (einschlie▀lich)
  2109.                       #                                bis z.index (ausschlie▀lich).
  2110.                      {var reg3 uintL len = z.index - z_start_index;
  2111.                       var reg4 object string;
  2112.                       if (len==0)
  2113.                         { string = NIL; } # "" wird zu NIL
  2114.                         else
  2115.                         { string = allocate_string(len); # String der LΣnge len
  2116.                           # fⁿllen:
  2117.                          {var reg1 uintB* ptr1 = &TheSstring(STACK_3)->data[z_start_index];
  2118.                           var reg2 uintB* ptr2 = &TheSstring(string)->data[0];
  2119.                           dotimespL(len,len, { *ptr2++ = *ptr1++; });
  2120.                         }}
  2121.                       # Name fertig.
  2122.                       if (nullp(STACK_0)
  2123.                           || (z.count==0)
  2124.                           || !slashp(TheSstring(STACK_3)->data[z.index])
  2125.                          )
  2126.                         { pushSTACK(string); break; }
  2127.                       # Character '.' ⁿbergehen:
  2128.                       z.index++; z.FNindex = fixnum_inc(z.FNindex,1); z.count--;
  2129.                       pushSTACK(string);
  2130.                     }}
  2131.                   if (!eq(STACK_1,unbound))
  2132.                     # (pathname-directory pathname) um Subdir STACK_1 verlΣngern:
  2133.                     { var reg1 object new_cons = allocate_cons(); # neues Cons
  2134.                       Car(new_cons) = STACK_1; # = (cons subdir NIL)
  2135.                       Cdr(STACK_2) = new_cons; # verlΣngert (pathname-directory Pathname)
  2136.                       STACK_2 = new_cons; # neues (last (pathname-directory Pathname))
  2137.                     }
  2138.                   STACK_1 = STACK_0; skipSTACK(1); # maybe-name := subdir
  2139.                 }
  2140.               if (eq(STACK_1,unbound)) { STACK_1 = STACK_0; STACK_0 = NIL; }
  2141.               # Stackaufbau: ..., Datenvektor, Pathname, (last (pathname-directory Pathname)),
  2142.               #              name, type.
  2143.               # In gewissen FΣllen h÷rt die Directory-Angabe nicht nach dem
  2144.               # vorletzten Punkt, sondern nach dem letzten Punkt auf:
  2145.               elif (eq(STACK_1,S(Kparent)) # z.B. "bar.^.foo"
  2146.                     || (nullp(STACK_0) && !nullp(STACK_1)) # z.B. "foo.bar."
  2147.                    )
  2148.                 # (pathname-directory pathname) um Subdir STACK_1 verlΣngern:
  2149.                 { var reg1 object new_cons = allocate_cons(); # neues Cons
  2150.                   Car(new_cons) = STACK_1; # = (cons subdir NIL)
  2151.                   Cdr(STACK_2) = new_cons; # verlΣngert (pathname-directory Pathname)
  2152.                   STACK_2 = new_cons; # neues (last (pathname-directory Pathname))
  2153.                   STACK_1 = STACK_0; # name := type
  2154.                   STACK_0 = NIL;     # type := NIL
  2155.                 }
  2156.               #endif
  2157.               #if defined(PATHNAME_EXT83) || defined(PATHNAME_RISCOS)
  2158.               # Stackaufbau: ...,
  2159.               #   Datenvektor, Pathname, (last (pathname-directory Pathname)),
  2160.               #   name, type.
  2161.               # Name und Typ in Pathname eintragen:
  2162.               { var reg3 object type = popSTACK();
  2163.                 var reg2 object name = popSTACK();
  2164.                 skipSTACK(1); # Directory ist schon eingetragen
  2165.                {var reg1 object pathname = STACK_0;
  2166.                 ThePathname(pathname)->pathname_name = name;
  2167.                 ThePathname(pathname)->pathname_type = type;
  2168.               }}
  2169.               #endif
  2170.               #ifdef PATHNAME_NOEXT
  2171.               # Stackaufbau: ..., Datenvektor, Pathname, (last (pathname-directory Pathname)),
  2172.               #              string.
  2173.               split_name_type(0); # String STACK_0 in Name und Typ aufspalten
  2174.               after_name_type:
  2175.               # Stackaufbau: ..., Datenvektor, Pathname, (last (pathname-directory Pathname)),
  2176.               #              name, type.
  2177.               # Name und Typ in Pathname eintragen:
  2178.               { var reg3 object type = popSTACK();
  2179.                 var reg2 object name = popSTACK();
  2180.                 skipSTACK(1); # Directory ist schon eingetragen
  2181.                 # name="" durch Name=NIL ersetzen:
  2182.                 if (equal(name,O(leer_string))) { name = NIL; }
  2183.                {var reg1 object pathname = STACK_0;
  2184.                 ThePathname(pathname)->pathname_name = name;
  2185.                 ThePathname(pathname)->pathname_type = type;
  2186.               }}
  2187.               #endif
  2188.             }
  2189.             #undef slashp
  2190.           }
  2191.         # Pathname fertig.
  2192.         # Stackaufbau: ..., Datenvektor, Pathname.
  2193.         if (!junk_allowed)
  2194.           # ▄berprⁿfen, ob keine Zeichen mehr ⁿbrig sind:
  2195.           if (!(z.count == 0))
  2196.             { pushSTACK(z.FNindex); # letzter Index
  2197.               pushSTACK(STACK_(4+2+1)); # thing
  2198.               pushSTACK(S(parse_namestring));
  2199.               fehler(error,
  2200.                      DEUTSCH ? "~: Syntax Error im Dateinamen ~ an Position ~." :
  2201.                      ENGLISH ? "~: syntax error in filename ~ at position ~" :
  2202.                      FRANCAIS ? "~ : Erreur de syntaxe dans le nom de fichier ~, α la position ~." :
  2203.                      ""
  2204.                     );
  2205.             }
  2206.         #ifdef LOGICAL_PATHNAMES
  2207.         if (parse_logical)
  2208.           { if (!nullp(STACK_(3+2)))
  2209.               # Hosts mⁿssen ⁿbereinstimmen, vgl. CLtL2 S. 629
  2210.               if (!equal(STACK_(3+2),TheLogpathname(STACK_0)->pathname_host))
  2211.                 { pushSTACK(STACK_0);
  2212.                   pushSTACK(TheLogpathname(STACK_(0+1))->pathname_host);
  2213.                   pushSTACK(STACK_(3+2+2));
  2214.                   pushSTACK(S(parse_namestring));
  2215.                   fehler(error,
  2216.                          DEUTSCH ? "~: Hosts ~ und ~ von ~ stimmen nicht ⁿberein." :
  2217.                          ENGLISH ? "~: hosts ~ and ~ of ~ should coincide" :
  2218.                          FRANCAIS ? "~ : Les ½hosts╗ ~ et ~ de ~ ne sont pas les mΩmes." :
  2219.                          ""
  2220.                         );
  2221.           }     }
  2222.         #endif
  2223.         value1 = STACK_0; # Pathname als 1. Wert
  2224.         #ifdef PATHNAME_RISCOS
  2225.         if (as_oint(z.FNindex) >= as_oint(FNindex_limit))
  2226.           # FNindex von new_thing nach thing umrechnen:
  2227.           { value2 = fixnum_inc(z.FNindex,FNindex_offset); }
  2228.           else
  2229.           # FNindex zeigt in den ersetzten (!) String envval. Was bleibt
  2230.           # uns als Index anderes ⁿbrig als der Start-Index?
  2231.           # (Nicht ganz korrekt freilich: HΣtte das Parsen wirklich dort
  2232.           # aufgeh÷rt, wⁿrde value1 anders aussehen!)
  2233.           # Zum Beispiel ein Index in das Innere des <...>-Konstruktes.
  2234.           # (Auch das ist nicht ganz korrekt, kommt der Sache aber nΣher.)
  2235.           { value2 = FNindex_fallback; }
  2236.         #else
  2237.         value2 = z.FNindex; # Index als 2. Wert
  2238.         #endif
  2239.         mv_count=2; # 2 Werte
  2240.         skipSTACK(5+2); return;
  2241.   } } }
  2242.  
  2243. # UP: Wandelt ein Objekt in einen Pathname um.
  2244. # coerce_xpathname(object)
  2245. # > object: Objekt
  2246. # < ergebnis: (PATHNAME Objekt)
  2247. # kann GC ausl÷sen
  2248.   local object coerce_xpathname (object obj);
  2249.   local object coerce_xpathname(obj)
  2250.     var reg1 object obj;
  2251.     { if (xpathnamep(obj))
  2252.         # Bei Pathnames ist nichts zu tun.
  2253.         { return obj; }
  2254.         else
  2255.         # sonst: PARSE-NAMESTRING aufrufen:
  2256.         { pushSTACK(subr_self); # subr_self retten (fⁿr spΣtere Fehlermeldungen)
  2257.           pushSTACK(obj); funcall(L(parse_namestring),1);
  2258.           subr_self = popSTACK();
  2259.           return value1;
  2260.         }
  2261.     }
  2262.  
  2263. LISPFUNN(pathname,1)
  2264. # (PATHNAME pathname), CLTL S. 413
  2265.   { value1 = coerce_xpathname(popSTACK()); mv_count=1; }
  2266.  
  2267. LISPFUN(pathnamehost,1,0,norest,key,1, (kw(case)))
  2268. # (PATHNAME-HOST pathname), CLTL S. 417, CLtL2 S. 644
  2269.   { var reg1 object pathname = coerce_xpathname(STACK_1);
  2270.     #ifdef LOGICAL_PATHNAMES
  2271.     if (logpathnamep(pathname))
  2272.       { value1 = TheLogpathname(pathname)->pathname_host; mv_count=1; }
  2273.       else
  2274.     #endif
  2275.       {
  2276.         #if HAS_HOST
  2277.         var reg2 object erg = ThePathname(pathname)->pathname_host;
  2278.         value1 = (eq(STACK_0,S(Kcommon)) ? common_case(erg) : erg);
  2279.         mv_count=1; # host als Wert
  2280.         #else
  2281.         value1 = NIL; mv_count=1; # NIL als Wert
  2282.         #endif
  2283.       }
  2284.     skipSTACK(2);
  2285.   }
  2286.  
  2287. LISPFUN(pathnamedevice,1,0,norest,key,1, (kw(case)))
  2288. # (PATHNAME-DEVICE pathname), CLTL S. 417, CLtL2 S. 644
  2289.   { var reg1 object pathname = coerce_xpathname(STACK_1);
  2290.     #ifdef LOGICAL_PATHNAMES
  2291.     if (logpathnamep(pathname))
  2292.       { value1 = NIL; mv_count=1; }
  2293.       else
  2294.     #endif
  2295.       {
  2296.         #if HAS_DEVICE
  2297.         var reg2 object erg = ThePathname(pathname)->pathname_device;
  2298.         value1 = (eq(STACK_0,S(Kcommon)) ? common_case(erg) : erg);
  2299.         mv_count=1; # device als Wert
  2300.         #else
  2301.         value1 = NIL; mv_count=1; # NIL als Wert
  2302.         #endif
  2303.       }
  2304.     skipSTACK(2);
  2305.   }
  2306.  
  2307. LISPFUN(pathnamedirectory,1,0,norest,key,1, (kw(case)))
  2308. # (PATHNAME-DIRECTORY pathname), CLTL S. 417, CLtL2 S. 644
  2309.   { var reg1 object pathname = coerce_xpathname(STACK_1);
  2310.     #ifdef LOGICAL_PATHNAMES
  2311.     if (logpathnamep(pathname))
  2312.       { value1 = TheLogpathname(pathname)->pathname_directory; }
  2313.       else
  2314.     #endif
  2315.       { var reg2 object erg = ThePathname(pathname)->pathname_directory;
  2316.         value1 = (eq(STACK_0,S(Kcommon)) ? subst_common_case(erg) : erg);
  2317.       }
  2318.     mv_count=1; # directory als Wert
  2319.     skipSTACK(2);
  2320.   }
  2321.  
  2322. LISPFUN(pathnamename,1,0,norest,key,1, (kw(case)))
  2323. # (PATHNAME-NAME pathname), CLTL S. 417, CLtL2 S. 644
  2324.   { var reg1 object pathname = coerce_xpathname(STACK_1);
  2325.     #ifdef LOGICAL_PATHNAMES
  2326.     if (logpathnamep(pathname))
  2327.       { value1 = TheLogpathname(pathname)->pathname_name; }
  2328.       else
  2329.     #endif
  2330.       { var reg2 object erg = ThePathname(pathname)->pathname_name;
  2331.         value1 = (eq(STACK_0,S(Kcommon)) ? common_case(erg) : erg);
  2332.       }
  2333.     mv_count=1; # name als Wert
  2334.     skipSTACK(2);
  2335.   }
  2336.  
  2337. LISPFUN(pathnametype,1,0,norest,key,1, (kw(case)))
  2338. # (PATHNAME-TYPE pathname), CLTL S. 417, CLtL2 S. 644
  2339.   { var reg1 object pathname = coerce_xpathname(STACK_1);
  2340.     #ifdef LOGICAL_PATHNAMES
  2341.     if (logpathnamep(pathname))
  2342.       { value1 = TheLogpathname(pathname)->pathname_type; }
  2343.       else
  2344.     #endif
  2345.       { var reg2 object erg = ThePathname(pathname)->pathname_type;
  2346.         value1 = (eq(STACK_0,S(Kcommon)) ? common_case(erg) : erg);
  2347.       }
  2348.     mv_count=1; # type als Wert
  2349.     skipSTACK(2);
  2350.   }
  2351.  
  2352. LISPFUNN(pathnameversion,1)
  2353. # (PATHNAME-VERSION pathname), CLTL S. 417, CLtL2 S. 644
  2354.   { var reg1 object pathname = coerce_xpathname(popSTACK());
  2355.     #ifdef LOGICAL_PATHNAMES
  2356.     if (logpathnamep(pathname))
  2357.       { value1 = TheLogpathname(pathname)->pathname_version; }
  2358.       else
  2359.     #endif
  2360.       {
  2361.         #if HAS_VERSION
  2362.         value1 = ThePathname(pathname)->pathname_version; # version als Wert
  2363.         #else
  2364.         value1 = NIL; # NIL als Wert
  2365.         #endif
  2366.       }
  2367.     mv_count=1;
  2368.   }
  2369.  
  2370. # Zugriffsfunktionen ohne Gro▀-/Klein-Umwandlung:
  2371. # xpathname_host(logical,pathname)
  2372. # xpathname_device(logical,pathname)
  2373. # xpathname_directory(logical,pathname)
  2374. # xpathname_name(logical,pathname)
  2375. # xpathname_type(logical,pathname)
  2376. # xpathname_version(logical,pathname)
  2377. # > pathname: Pathname oder Logical Pathname
  2378. # > logical: Flag, ob es sich um einen Logical Pathname handelt
  2379. # < ergebnis: Wert der entsprechenden Komponente von pathname
  2380.   #ifdef LOGICAL_PATHNAMES
  2381.     #if HAS_HOST
  2382.       #define xpathname_host(logical,pathname)  \
  2383.         (logical ? TheLogpathname(pathname)->pathname_host : ThePathname(pathname)->pathname_host)
  2384.     #else
  2385.       #define xpathname_host(logical,pathname)  \
  2386.         (logical ? TheLogpathname(pathname)->pathname_host : NIL)
  2387.     #endif
  2388.     #if HAS_DEVICE
  2389.       #define xpathname_device(logical,pathname)  \
  2390.         (logical ? NIL : ThePathname(pathname)->pathname_device)
  2391.     #else
  2392.       #define xpathname_device(logical,pathname)  NIL
  2393.     #endif
  2394.     #define xpathname_directory(logical,pathname)  \
  2395.       (logical ? TheLogpathname(pathname)->pathname_directory : ThePathname(pathname)->pathname_directory)
  2396.     #define xpathname_name(logical,pathname)  \
  2397.       (logical ? TheLogpathname(pathname)->pathname_name : ThePathname(pathname)->pathname_name)
  2398.     #define xpathname_type(logical,pathname)  \
  2399.       (logical ? TheLogpathname(pathname)->pathname_type : ThePathname(pathname)->pathname_type)
  2400.     #if HAS_VERSION
  2401.       #define xpathname_version(logical,pathname)  \
  2402.         (logical ? TheLogpathname(pathname)->pathname_version : ThePathname(pathname)->pathname_version)
  2403.     #else
  2404.       #define xpathname_version(logical,pathname)  \
  2405.         (logical ? TheLogpathname(pathname)->pathname_version : NIL)
  2406.     #endif
  2407.   #else
  2408.     # logical immer =FALSE
  2409.     #if HAS_HOST
  2410.       #define xpathname_host(logical,pathname)  ThePathname(pathname)->pathname_host
  2411.     #else
  2412.       #define xpathname_host(logical,pathname)  NIL
  2413.     #endif
  2414.     #if HAS_DEVICE
  2415.       #define xpathname_device(logical,pathname)  ThePathname(pathname)->pathname_device
  2416.     #else
  2417.       #define xpathname_device(logical,pathname)  NIL
  2418.     #endif
  2419.     #define xpathname_directory(logical,pathname)  ThePathname(pathname)->pathname_directory
  2420.     #define xpathname_name(logical,pathname)  ThePathname(pathname)->pathname_name
  2421.     #define xpathname_type(logical,pathname)  ThePathname(pathname)->pathname_type
  2422.     #if HAS_VERSION
  2423.       #define xpathname_version(logical,pathname)  ThePathname(pathname)->pathname_version
  2424.     #else
  2425.       #define xpathname_version(logical,pathname)  NIL
  2426.     #endif
  2427.   #endif
  2428.  
  2429. #ifdef LOGICAL_PATHNAMES
  2430.  
  2431. LISPFUNN(logical_pathname,1)
  2432. # (LOGICAL-PATHNAME thing), CLtL2 S. 631
  2433.   { var reg1 object thing = popSTACK();
  2434.     if (logpathnamep(thing))
  2435.       # Bei Logical Pathnames ist nichts zu tun.
  2436.       { value1 = thing; mv_count=1; }
  2437.     elif (pathnamep(thing))
  2438.       # Normale Pathnames k÷nnen nicht in Logical Pathnames umgewandelt werden.
  2439.       { pushSTACK(thing); # Wert fⁿr Slot DATUM von TYPE-ERROR
  2440.         pushSTACK(O(type_logical_pathname)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  2441.         pushSTACK(thing);
  2442.         pushSTACK(S(logical_pathname));
  2443.         fehler(type_error,
  2444.                DEUTSCH ? "~: Argument ~ ist kein Logical Pathname, String, Stream oder Symbol." :
  2445.                ENGLISH ? "~: argument ~ is not a logical pathname, string, stream or symbol" :
  2446.                FRANCAIS ? "~ : L'argument ~ n'est pas un ½pathname logique╗, une chaεne, un ½stream╗ ou un symbole." :
  2447.                ""
  2448.               );
  2449.       }
  2450.     else
  2451.       # sonst: PARSE-NAMESTRING aufrufen:
  2452.       { pushSTACK(subr_self); # subr_self retten (fⁿr spΣtere Fehlermeldungen)
  2453.         # Das Ergebnis von (PARSE-NAMESTRING thing nil empty-logical-pathname)
  2454.         # ist garantiert ein logischer Pathname.
  2455.         pushSTACK(thing); pushSTACK(NIL); pushSTACK(O(empty_logical_pathname));
  2456.         funcall(L(parse_namestring),3);
  2457.         subr_self = popSTACK();
  2458.         mv_count=1;
  2459.       }
  2460.   }
  2461.  
  2462. LISPFUN(translate_logical_pathname,1,0,norest,key,0, )
  2463. # (TRANSLATE-LOGICAL-PATHNAME pathname &key), CLtL2 S. 631
  2464.   { var reg3 object pathname = coerce_xpathname(popSTACK());
  2465.     if (logpathnamep(pathname))
  2466.       { # Umwandeln eines logischen in einen normalen Pathname:
  2467.         # (let ((ht (make-hash-table :test #'equal)))
  2468.         #   (loop
  2469.         #     (when (gethash pathname ht) (error "Translation loop"))
  2470.         #     (setf (gethash pathname ht) t)
  2471.         #     (let ((host (or (pathname-host pathname) "SYS")))
  2472.         #       (unless (logical-host-p host) (error "No translation for host"))
  2473.         #       (let* ((translations (gethash host sys::*logical-pathname-translations*))
  2474.         #              (translation (assoc pathname translations :test #'pathname-match-p)))
  2475.         #         (unless (and translation (consp translation) (consp (cdr translation)))
  2476.         #           (error "No translation for pathname")
  2477.         #         )
  2478.         #         (setq pathname (translate-pathname pathname (first translation) (second translation)))
  2479.         #     ) )
  2480.         #     (unless (sys::logical-pathname-p pathname) (return))
  2481.         #   )
  2482.         #   pathname
  2483.         # )
  2484.         pushSTACK(pathname);
  2485.         pushSTACK(S(Ktest)); pushSTACK(L(equal)); funcall(L(make_hash_table),2);
  2486.         pushSTACK(value1);
  2487.         # Stackaufbau: pathname, ht.
  2488.         loop
  2489.           { if (!nullp(shifthash(STACK_0,STACK_1,T)))
  2490.               { # STACK_1 = pathname; # Wert fⁿr Slot PATHNAME von FILE-ERROR
  2491.                 STACK_0 = STACK_1;
  2492.                 pushSTACK(S(translate_logical_pathname));
  2493.                 fehler(file_error,
  2494.                        DEUTSCH ? "~: Endlosschleife beim Aufl÷sen von ~" :
  2495.                        ENGLISH ? "~: endless loop while resolving ~" :
  2496.                        FRANCAIS ? "~ : boucle infinie pour ~" :
  2497.                        ""
  2498.                       );
  2499.               }
  2500.             if (nullp(TheLogpathname(STACK_1)->pathname_host))
  2501.               # Host NIL durch Default-Host ersetzen:
  2502.               { var reg1 object new = allocate_logpathname();
  2503.                 var reg2 object old = STACK_1;
  2504.                 TheLogpathname(new)->pathname_host      = O(default_logical_pathname_host); # Default "SYS"
  2505.                 TheLogpathname(new)->pathname_directory = TheLogpathname(old)->pathname_directory;
  2506.                 TheLogpathname(new)->pathname_name      = TheLogpathname(old)->pathname_name;
  2507.                 TheLogpathname(new)->pathname_type      = TheLogpathname(old)->pathname_type;
  2508.                 TheLogpathname(new)->pathname_version   = TheLogpathname(old)->pathname_version;
  2509.                 STACK_1 = new;
  2510.               }
  2511.            {var reg2 object host = TheLogpathname(STACK_1)->pathname_host;
  2512.             var reg1 object translations = gethash(host,Symbol_value(S(logpathname_translations)));
  2513.             if (eq(translations,nullobj))
  2514.               { # STACK_1 = pathname; # Wert fⁿr Slot PATHNAME von FILE-ERROR
  2515.                 STACK_0 = STACK_1;
  2516.                 pushSTACK(host);
  2517.                 pushSTACK(S(translate_logical_pathname));
  2518.                 fehler(file_error,
  2519.                        DEUTSCH ? "~: Logical Host ~ ist unbekannt: ~" :
  2520.                        ENGLISH ? "~: unknown logical host ~ in ~" :
  2521.                        FRANCAIS ? "~ : host ~ inconnu dans ~" :
  2522.                        ""
  2523.                       );
  2524.               }
  2525.             # (ASSOC pathname translations :test #'pathname-match-p):
  2526.             pushSTACK(STACK_1); pushSTACK(translations);
  2527.             pushSTACK(S(Ktest)); pushSTACK(L(pathname_match_p));
  2528.             funcall(L(assoc),4);
  2529.             if (atomp(value1) || matomp(Cdr(value1)))
  2530.               { # STACK_1 = pathname; # Wert fⁿr Slot PATHNAME von FILE-ERROR
  2531.                 STACK_0 = STACK_1;
  2532.                 pushSTACK(S(translate_logical_pathname));
  2533.                 fehler(file_error,
  2534.                        DEUTSCH ? "~: Keine Ersetzungsregel fⁿr ~ ist bekannt." :
  2535.                        ENGLISH ? "~: No replacement rule for ~ is known." :
  2536.                        FRANCAIS ? "~ : Aucune rΦgle de traduction est connue pour ~." :
  2537.                        ""
  2538.                       );
  2539.               }
  2540.             # (TRANSLATE-PATHNAME pathname (first rule) (second rule) :MERGE NIL):
  2541.             pushSTACK(STACK_1); pushSTACK(Car(value1)); pushSTACK(Car(Cdr(value1)));
  2542.             pushSTACK(S(Kmerge)); pushSTACK(NIL);
  2543.             funcall(L(translate_pathname),5);
  2544.             STACK_1 = pathname = value1;
  2545.             if (!logpathnamep(pathname)) break;
  2546.           }}
  2547.         skipSTACK(2);
  2548.       }
  2549.     value1 = pathname; mv_count=1;
  2550.   }
  2551.  
  2552. # UP: Wandelt ein Objekt in einen nicht-Logical Pathname um.
  2553. # coerce_pathname(object)
  2554. # > object: Objekt
  2555. # < ergebnis: (TRANSLATE-LOGICAL-PATHNAME (PATHNAME Objekt))
  2556. # kann GC ausl÷sen
  2557.   local object coerce_pathname (object obj);
  2558.   local object coerce_pathname(obj)
  2559.     var reg1 object obj;
  2560.     { obj = coerce_xpathname(obj);
  2561.       if (pathnamep(obj))
  2562.         # Bei Pathnames ist nichts zu tun.
  2563.         { return obj; }
  2564.       elif (logpathnamep(obj))
  2565.         # TRANSLATE-LOGICAL-PATHNAME aufrufen:
  2566.         { pushSTACK(subr_self); # subr_self retten (fⁿr spΣtere Fehlermeldungen)
  2567.           pushSTACK(obj); funcall(L(translate_logical_pathname),1);
  2568.           subr_self = popSTACK();
  2569.           return value1;
  2570.         }
  2571.       else
  2572.         { NOTREACHED }
  2573.     }
  2574.  
  2575. #endif
  2576.  
  2577. # UP: Legt Teilstrings fⁿr STRING_CONCAT auf den STACK, die zusammen den
  2578. # String fⁿr ein Subdirectory (car path) ergeben.
  2579. # subdir_namestring_parts(path)
  2580. # > path: ein Cons
  2581. # < ergebnis: Anzahl der auf den Stack gelegten Strings
  2582. # verΣndert STACK
  2583.   local uintC subdir_namestring_parts (object path);
  2584.   local uintC subdir_namestring_parts(path)
  2585.     var reg4 object path;
  2586.     { var reg1 object subdir = Car(path);
  2587.       #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS)
  2588.       if (eq(subdir,S(Kcurrent))) # :CURRENT ?
  2589.         { pushSTACK(O(punkt_string)); return 1; }
  2590.       elif (eq(subdir,S(Kparent))) # :PARENT ?
  2591.         { pushSTACK(O(punktpunkt_string)); return 1; }
  2592.       elif (eq(subdir,S(Kwild_inferiors))) # :WILD-INFERIORS ?
  2593.         { pushSTACK(O(punktpunktpunkt_string)); return 1; }
  2594.       else
  2595.         # normales subdir (name . type)
  2596.         { var reg3 object name = Car(subdir);
  2597.           var reg2 object type = Cdr(subdir);
  2598.           # name = :WILD -> String "*"
  2599.           if (eq(name,S(Kwild))) { name = O(wild_string); }
  2600.           pushSTACK(name);
  2601.           # type = :WILD -> String "*"
  2602.           if (eq(type,S(Kwild))) { type = O(wild_string); }
  2603.           if (TheSstring(type)->length == 0)
  2604.             # type = "" -> nicht auszugeben
  2605.             { return 1+0; }
  2606.             else
  2607.             { pushSTACK(O(punkt_string)); # "."
  2608.               pushSTACK(type);
  2609.               return 1+2;
  2610.             }
  2611.         }
  2612.       #endif
  2613.       #ifdef PATHNAME_AMIGAOS
  2614.       if (eq(subdir,S(Kparent))) # :PARENT ?
  2615.         { return 0; } # Leerstring
  2616.       elif (eq(subdir,S(Kwild_inferiors))) # :WILD-INFERIORS ?
  2617.         { pushSTACK(O(wildwild_string)); return 1; }
  2618.       else
  2619.         # normales subdir
  2620.         { pushSTACK(subdir); return 1; }
  2621.       #endif
  2622.       #if defined(PATHNAME_UNIX) || defined(PATHNAME_OS2)
  2623.       if (eq(subdir,S(Kwild_inferiors))) # :WILD-INFERIORS ?
  2624.         { pushSTACK(O(wildwild_string)); return 1; }
  2625.         else
  2626.         # normales subdir
  2627.         { pushSTACK(subdir); return 1; }
  2628.       #endif
  2629.       #ifdef PATHNAME_RISCOS
  2630.       if (eq(subdir,S(Kparent))) # :PARENT ?
  2631.         { pushSTACK(O(parent_string)); return 1; }
  2632.         else
  2633.         # normales subdir
  2634.         { pushSTACK(subdir); return 1; }
  2635.       #endif
  2636.     }
  2637.  
  2638. # UP: Legt Teilstrings fⁿr STRING_CONCAT auf den STACK, die zusammen den
  2639. # String fⁿr den Host des Pathname pathname ergeben.
  2640. # host_namestring_parts(pathname)
  2641. # > pathname: nicht-Logical Pathname
  2642. # < ergebnis: Anzahl der auf den Stack gelegten Strings
  2643. # verΣndert STACK
  2644. #if HAS_HOST
  2645.   local uintC host_namestring_parts (object pathname);
  2646.   local uintC host_namestring_parts(pathname)
  2647.     var reg1 object pathname;
  2648.     { var reg2 object host = ThePathname(pathname)->pathname_host;
  2649.       if (nullp(host))
  2650.         { return 0; } # kein String
  2651.         else
  2652.         { pushSTACK(host);
  2653.           pushSTACK(O(doppelpunkt_string)); # ":"
  2654.           return 2;
  2655.     }   }
  2656. #else
  2657.   #define host_namestring_parts(pathname)  (pathname,0)  # keine Strings
  2658. #endif
  2659.  
  2660. # UP: Legt Teilstrings fⁿr STRING_CONCAT auf den STACK, die zusammen den
  2661. # String fⁿrs Device und Directory des Pathname pathname ergeben.
  2662. #if HAS_SERNR
  2663. # directory_namestring_parts(pathname,skipSN)
  2664. # > skipSN: Flag, ob Seriennummer unterdrⁿckt werden soll
  2665. # > pathname: nicht-Logical Pathname
  2666. # < ergebnis: Anzahl der auf den Stack gelegten Strings
  2667. # falls skipSN: verΣndert STACK
  2668. # falls !skipSN: verΣndert STACK, kann GC ausl÷sen
  2669. #else
  2670. # directory_namestring_parts(pathname)
  2671. # > pathname: nicht-Logical Pathname
  2672. # < ergebnis: Anzahl der auf den Stack gelegten Strings
  2673. # verΣndert STACK
  2674. #endif
  2675.   #if HAS_SERNR
  2676.   local uintC directory_namestring_parts (object pathname, boolean skipSN);
  2677.   #define directory_namestring_parts_(pathname)  \
  2678.     directory_namestring_parts(pathname,TRUE)
  2679.   local uintC directory_namestring_parts PARM2(pathname,skipSN,
  2680.     var reg4 object pathname,
  2681.     var reg5 boolean skipSN)
  2682.   #else
  2683.   local uintC directory_namestring_parts (object pathname);
  2684.   #define directory_namestring_parts_(pathname)  \
  2685.     directory_namestring_parts(pathname)
  2686.   local uintC directory_namestring_parts PARM1(pathname,
  2687.     var reg4 object pathname)
  2688.   #endif
  2689.     { var reg3 uintC stringcount = 0; # bisherige Stringzahl = 0
  2690.       #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  2691.       # Device:
  2692.       { var reg1 object device = ThePathname(pathname)->pathname_device;
  2693.         if (!(nullp(device))) # NIL -> kein String
  2694.           { if (eq(device,S(Kwild))) { device = O(wild_string); } # :WILD -> String "*"
  2695.             pushSTACK(device); # Device auf den Stack
  2696.             stringcount++; # und mitzΣhlen
  2697.       }   }
  2698.       #endif
  2699.       #ifdef PATHNAME_AMIGAOS
  2700.       # Device:
  2701.       { var reg1 object device = ThePathname(pathname)->pathname_device;
  2702.         if (!(nullp(device))) # NIL -> kein String
  2703.           { pushSTACK(device); # Device auf den Stack
  2704.             stringcount += 1; # und mitzΣhlen
  2705.             # Wegen :ABSOLUTE kommt gleich danach ein ":" auf den Stack.
  2706.       }   }
  2707.       #endif
  2708.       #ifdef PATHNAME_RISCOS
  2709.       # Device:
  2710.       { var reg1 object device = ThePathname(pathname)->pathname_device;
  2711.         if (!(nullp(device))) # NIL -> kein String
  2712.           { pushSTACK(O(doppelpunkt_string)); # ":"
  2713.             pushSTACK(device); # Device auf den Stack
  2714.             pushSTACK(O(punkt_string)); # "."
  2715.             stringcount += 3; # und mitzΣhlen
  2716.       }   }
  2717.       #endif
  2718.       # Directory:
  2719.       { var reg2 object directory = ThePathname(pathname)->pathname_directory;
  2720.         #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  2721.         #if HAS_SERNR
  2722.         if (!skipSN)
  2723.           { var reg1 object seriennummer = Car(directory);
  2724.             if (!nullp(seriennummer))
  2725.               { # Seriennummer in dezimal umwandeln:
  2726.                 pushSTACK(directory); # directory retten
  2727.                 # (WRITE-TO-STRING Seriennummer :BASE 10 :RADIX NIL) ausfⁿhren:
  2728.                 pushSTACK(seriennummer); # 1. Argument
  2729.                 apply(L(write_to_string),1,O(base10_radixnil));
  2730.                 directory = popSTACK();
  2731.                 pushSTACK(value1); # Ergebnis-String in den Stack
  2732.                 stringcount++; # und mitzΣhlen
  2733.           }   }
  2734.         directory = Cdr(directory); # restliche subdirs
  2735.         #endif
  2736.         # evtl. Doppelpunkt:
  2737.         if (!(stringcount == 0)) # nur falls schon was auf dem Stack
  2738.           { pushSTACK(O(doppelpunkt_string)); stringcount++; } # ":" auf den Stack
  2739.         #endif
  2740.         # Ist das erste subdir = :ABSOLUTE oder = :RELATIVE ?
  2741.         if (eq(Car(directory),S(Kabsolute)))
  2742.           #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  2743.           { pushSTACK(O(backslash_string)); stringcount++; } # "\\" auf den Stack
  2744.           #endif
  2745.           #ifdef PATHNAME_AMIGAOS
  2746.           { pushSTACK(O(doppelpunkt_string)); stringcount++; } # ":" auf den Stack
  2747.           #endif
  2748.           #ifdef PATHNAME_UNIX
  2749.           { pushSTACK(O(slash_string)); stringcount++; } # "/" auf den Stack
  2750.           #endif
  2751.           #ifdef PATHNAME_RISCOS
  2752.           { directory = Cdr(directory); # ⁿbergehen
  2753.            {var reg1 object firstdir = Car(directory);
  2754.             if (eq(firstdir,S(Kroot)))
  2755.               { pushSTACK(O(root_string)); stringcount++; } # "$." auf den Stack
  2756.             elif (eq(firstdir,S(Khome)))
  2757.               { pushSTACK(O(home_string)); stringcount++; } # "&." auf den Stack
  2758.             elif (eq(firstdir,S(Kcurrent)))
  2759.               { pushSTACK(O(current_string)); stringcount++; } # "@." auf den Stack
  2760.             elif (eq(firstdir,S(Klibrary)))
  2761.               { pushSTACK(O(library_string)); stringcount++; } # "%." auf den Stack
  2762.             elif (eq(firstdir,S(Kprevious)))
  2763.               { pushSTACK(O(previous_string)); stringcount++; } # "\\." auf den Stack
  2764.             else
  2765.               { NOTREACHED }
  2766.           }}
  2767.           #endif
  2768.         directory = Cdr(directory); # ⁿbergehen
  2769.         # weitere subdirs auf den Stack:
  2770.         while (consp(directory))
  2771.           { stringcount += subdir_namestring_parts(directory);
  2772.             #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  2773.             pushSTACK(O(backslash_string)); stringcount++; # "\\" auf den Stack
  2774.             #endif
  2775.             #if defined(PATHNAME_UNIX) || defined(PATHNAME_AMIGAOS)
  2776.             pushSTACK(O(slash_string)); stringcount++; # "/" auf den Stack
  2777.             #endif
  2778.             #ifdef PATHNAME_RISCOS
  2779.             pushSTACK(O(punkt_string)); stringcount++; # "." auf den Stack
  2780.             #endif
  2781.             directory = Cdr(directory);
  2782.           }
  2783.       }
  2784.       return stringcount;
  2785.     }
  2786.  
  2787. # UP: Legt Teilstrings fⁿr STRING_CONCAT auf den STACK, die zusammen den
  2788. # String fⁿr Name und Typ des Pathname ergeben.
  2789. # nametype_namestring_parts(name,type,version)
  2790. # > name, type, evtl. version: Komponenten des Pathname
  2791. # < ergebnis: Anzahl der auf den Stack gelegten Strings
  2792. # kann GC ausl÷sen
  2793. # verΣndert STACK
  2794.   #if HAS_VERSION
  2795.   local uintC nametype_namestring_parts (object name, object type, object version);
  2796.   local uintC nametype_namestring_parts PARM3(name,type,version,
  2797.     var reg2 object name,
  2798.     var reg1 object type,
  2799.     var reg4 object version)
  2800.   #else
  2801.   local uintC nametype_namestring_parts_ (object name, object type);
  2802.   local uintC nametype_namestring_parts_ PARM2(name,type,
  2803.     var reg2 object name,
  2804.     var reg1 object type)
  2805.   #define nametype_namestring_parts(n,t,v)  nametype_namestring_parts_(n,t)
  2806.   #endif
  2807.     { var reg3 uintC stringcount = 0;
  2808.       # Name:
  2809.       if (!nullp(name)) # name=NIL -> nicht ausgeben
  2810.         {
  2811.           #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS)
  2812.           if (eq(name,S(Kwild))) { name = O(wild_string); } # :WILD -> String "*"
  2813.           #endif
  2814.           pushSTACK(name); # Name auf den Stack
  2815.           stringcount++; # und mitzΣhlen
  2816.         }
  2817.       # Typ:
  2818.       if (!nullp(type)) # type=NIL -> nicht ausgeben
  2819.         { pushSTACK(O(punkt_string)); # "." auf den Stack
  2820.           stringcount++; # und mitzΣhlen
  2821.           #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS)
  2822.           if (eq(type,S(Kwild))) { type = O(wild_string); } # :WILD -> String "*"
  2823.           #endif
  2824.           pushSTACK(type); # Typ auf den Stack
  2825.           stringcount++; # und mitzΣhlen
  2826.         }
  2827.       #if HAS_VERSION
  2828.       if (!nullp(version)) # version=NIL -> nicht ausgeben
  2829.         { pushSTACK(O(strichpunkt_string)); # ";" auf den Stack
  2830.           stringcount++; # und mitzΣhlen
  2831.           if (eq(version,S(Knewest)))
  2832.             { pushSTACK(O(zero_string)); } # :NEWEST -> String "0"
  2833.             else
  2834.           # Version (Integer >0) in String umwandeln: (sys::decimal-string version)
  2835.           { pushSTACK(version);
  2836.             C_decimal_string(); # == funcall(L(decimal_string),1);
  2837.             pushSTACK(value1);
  2838.           }
  2839.           stringcount++; # und mitzΣhlen
  2840.         }
  2841.       #endif
  2842.       return stringcount;
  2843.     }
  2844.  
  2845. # UP: Legt Teilstrings fⁿr STRING_CONCAT auf den STACK, die zusammen den
  2846. # String fⁿr Name und Typ des Pathname ergeben.
  2847. # file_namestring_parts(pathname)
  2848. # > pathname: nicht-Logical Pathname
  2849. # < ergebnis: Anzahl der auf den Stack gelegten Strings
  2850. # kann GC ausl÷sen
  2851. # verΣndert STACK
  2852.   local uintC file_namestring_parts (object pathname);
  2853.   local uintC file_namestring_parts(pathname)
  2854.     var reg1 object pathname;
  2855.     { return nametype_namestring_parts(ThePathname(pathname)->pathname_name,
  2856.                                        ThePathname(pathname)->pathname_type,
  2857.                                        ThePathname(pathname)->pathname_version);
  2858.     }
  2859.  
  2860. # UP: Wandelt Pathname in String um.
  2861. # whole_namestring(pathname)
  2862. # > pathname: nicht-Logical Pathname
  2863. # < ergebnis: Simple-String
  2864. # kann GC ausl÷sen
  2865.   local object whole_namestring (object pathname);
  2866.   local object whole_namestring(pathname)
  2867.     var reg1 object pathname;
  2868.     { var reg2 uintC stringcount;
  2869.       #if HAS_SERNR
  2870.       pushSTACK(pathname); # pathname retten
  2871.       {var reg3 object* pathname_ = &STACK_0;
  2872.        stringcount = host_namestring_parts(pathname); # Strings fⁿr den Host
  2873.        stringcount += directory_namestring_parts(pathname,FALSE); # Strings fⁿrs Directory
  2874.        pathname = *pathname_;
  2875.       }
  2876.       #else
  2877.       stringcount = host_namestring_parts(pathname); # Strings fⁿr den Host
  2878.       stringcount += directory_namestring_parts(pathname); # Strings fⁿrs Directory
  2879.       #endif
  2880.       stringcount += file_namestring_parts(pathname); # Strings fⁿr den Filename
  2881.       subr_self = L(namestring); # ("aktuelles" SUBR fⁿr Fehlermeldung)
  2882.      {var reg3 object ergebnis = string_concat(stringcount); # zusammenhΣngen
  2883.       #if HAS_SERNR
  2884.       skipSTACK(1); # pathname wieder vergessen
  2885.       #endif
  2886.       return ergebnis;
  2887.     }}
  2888.  
  2889. LISPFUNN(file_namestring,1)
  2890. # (FILE-NAMESTRING pathname), CLTL S. 417
  2891.   { var reg1 object pathname = coerce_pathname(popSTACK());
  2892.     var reg2 uintC stringcount = file_namestring_parts(pathname); # Strings fⁿr den Filename
  2893.     value1 = string_concat(stringcount); mv_count=1; # zusammenhΣngen
  2894.   }
  2895.  
  2896. # UP: Liefert den String zum Directory eines Pathname.
  2897. # directory_namestring(pathname)
  2898. # > pathname: nicht-Logical Pathname
  2899. # > subr_self: Aufrufer (ein SUBR)
  2900. # < ergebnis: Simple-String
  2901. # kann GC ausl÷sen
  2902.   local object directory_namestring (object pathname);
  2903.   local object directory_namestring(pathname)
  2904.     var reg1 object pathname;
  2905.     { var reg2 uintC stringcount =
  2906.         #if HAS_SERNR
  2907.         directory_namestring_parts(pathname,FALSE); # Strings fⁿrs Directory
  2908.         #else
  2909.         directory_namestring_parts(pathname); # Strings fⁿrs Directory
  2910.         #endif
  2911.       return string_concat(stringcount); # zusammenhΣngen
  2912.     }
  2913.  
  2914. LISPFUNN(directory_namestring,1)
  2915. # (DIRECTORY-NAMESTRING pathname), CLTL S. 417
  2916.   { var reg1 object pathname = coerce_pathname(popSTACK());
  2917.     value1 = directory_namestring(pathname); mv_count=1;
  2918.   }
  2919.  
  2920. LISPFUNN(host_namestring,1)
  2921. # (HOST-NAMESTRING pathname), CLTL S. 417
  2922.   { var reg1 object pathname = coerce_pathname(popSTACK());
  2923.     #if HAS_HOST
  2924.     var reg2 uintC stringcount = host_namestring_parts(pathname); # Strings fⁿr den Host
  2925.     value1 = string_concat(stringcount); # zusammenhΣngen
  2926.     #else
  2927.     value1 = O(leer_string); # "" als Wert
  2928.     #endif
  2929.     mv_count=1;
  2930.   }
  2931.  
  2932. #if HAS_VERSION || defined(LOGICAL_PATHNAMES)
  2933. # UP: ▄berprⁿft ein optionales VERSION-Argument.
  2934. # test_optional_version(def);
  2935. # > STACK_0: VERSION-Argument
  2936. # > def: Defaultwert dafⁿr
  2937. # > subr_self: Aufrufer (ein SUBR)
  2938. # < ergebnis: gⁿltige Version-Komponente
  2939.   local object test_optional_version (object def);
  2940.   local object test_optional_version(def)
  2941.     var reg2 object def;
  2942.     { var reg1 object version = STACK_0;
  2943.       if (eq(version,unbound)) { return def; } # nicht angegeben -> Default
  2944.       elif (nullp(version)) {} # NIL ist OK
  2945.       elif (eq(version,S(Kwild))) {} # :WILD ist OK
  2946.       elif (eq(version,S(Knewest))) {} # :NEWEST ist OK
  2947.       elif (posfixnump(version) && !eq(version,Fixnum_0)) {} # Fixnum >0 ist OK
  2948.       elif (pathnamep(version)) # Pathname -> dessen Version
  2949.         { STACK_0 = xpathname_version(FALSE,version); }
  2950.       #ifdef LOGICAL_PATHNAMES
  2951.       elif (logpathnamep(version)) # Logical Pathname -> dessen Version
  2952.         { STACK_0 = TheLogpathname(version)->pathname_version; }
  2953.       #endif
  2954.       else # Keiner der gewⁿnschten FΣlle -> Fehler:
  2955.         { pushSTACK(version); # Wert fⁿr Slot DATUM von TYPE-ERROR
  2956.           pushSTACK(O(type_version)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  2957.           pushSTACK(version);
  2958.           pushSTACK(TheSubr(subr_self)->name);
  2959.           fehler(type_error,
  2960.                  DEUTSCH ? "~: :VERSION-Argument mu▀ NIL oder ein Fixnum >0 oder :WILD oder :NEWEST sein, nicht ~" :
  2961.                  ENGLISH ? "~: :VERSION-argument should be NIL or a positive fixnum or :WILD or :NEWEST, not ~" :
  2962.                  FRANCAIS ? "~ : L'argument pour :VERSION doit Ωtre NIL, un petit nombre entier positif, :WILD ou :NEWEST mais non ~" :
  2963.                  ""
  2964.                 );
  2965.         }
  2966.       return version;
  2967.     }
  2968. #else
  2969. # UP: ▄berprⁿft ein optionales VERSION-Argument.
  2970. # test_optional_version();
  2971. # > STACK_0: VERSION-Argument
  2972. # > subr_self: Aufrufer (ein SUBR)
  2973.   #define test_optional_version(def)  test_optional_version_()
  2974.   local void test_optional_version_ (void);
  2975.   local void test_optional_version_()
  2976.     { var reg1 object version = STACK_0;
  2977.       if (eq(version,unbound) # nicht angegeben?
  2978.           || nullp(version)         # oder NIL ?
  2979.           || eq(version,S(Kwild))   # oder :WILD ?
  2980.           || eq(version,S(Knewest)) # oder :NEWEST ?
  2981.          )
  2982.         { return; } # ja -> OK
  2983.         else
  2984.         { pushSTACK(version); # Wert fⁿr Slot DATUM von TYPE-ERROR
  2985.           pushSTACK(O(type_version)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  2986.           pushSTACK(version);
  2987.           pushSTACK(TheSubr(subr_self)->name);
  2988.           fehler(type_error,
  2989.                  DEUTSCH ? "~: :VERSION-Argument mu▀ NIL oder :WILD oder :NEWEST sein, nicht ~" :
  2990.                  ENGLISH ? "~: :VERSION-argument should be NIL or :WILD or :NEWEST, not ~" :
  2991.                  FRANCAIS ? "~ : L'argument pour :VERSION doit Ωtre NIL, :WILD ou :NEWEST mais non ~" :
  2992.                  ""
  2993.                 );
  2994.     }   }
  2995. #endif
  2996.  
  2997. #ifdef PATHNAME_ATARI
  2998.  
  2999. # Suchbuffer fⁿr GEMDOS:
  3000.   local DTA DTA_buffer;
  3001.  
  3002. # Es wird ein Default-Drive gefⁿhrt: DEFAULT_DRIVE = O(default_drive).
  3003.  
  3004. # Die Variable *DEFAULT-PATHNAME-DEFAULTS* enthΣlt (als Pathname) den
  3005. # Defaultwert fⁿr jede MERGE-Operation. Dies ist derjenige, den das System
  3006. # in vom Benutzer eingegebene Pathnames "hineininterpretiert".
  3007. # Er wird auf dem neuesten Stand des DEFAULT_DRIVE gehalten: bei der
  3008. # Initialisierung das aktuelle Device (im Sinne von GEMDOS), bei der
  3009. # ─nderung von DEFAULT_DRIVE mittels CD.
  3010.  
  3011. # Es wird eine Liste aller angeschlossenen Laufwerke und der Default-
  3012. # Directories bei allen bekannten Disketten gefⁿhrt. Aufbau:
  3013. # ( { (device . ( { (Seriennummer . default-directory) } ) ) } )
  3014. # also eine Aliste, die abbildet:
  3015. # device (String der LΣnge 1) -> Aliste (Seriennummer -> default-directory),
  3016. # wobei die default-directories Pathnames sind, bei denen nur Device und
  3017. # Directory gefⁿllt sind, keine Wildcards vorkommen und das Directory
  3018. # nur subdirs der Form (name . type) enthΣlt.
  3019. # Variable DRIVE_ALIST = O(drive_alist).
  3020.  
  3021. #endif # PATHNAME_ATARI
  3022.  
  3023. #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  3024.  
  3025. # Das Betriebssystem verwaltet ein Default-Drive.
  3026. # Das Betriebssystem verwaltet auf jedem Drive ein Default-Directory. Dieses
  3027. # kann sich allerdings Σndern, wenn eine andere Diskette eingelegt wird.
  3028.  
  3029. # Es wird ein Default-Drive gefⁿhrt: DEFAULT_DRIVE = O(default_drive).
  3030.  
  3031. # Die Variable *DEFAULT-PATHNAME-DEFAULTS* enthΣlt (als Pathname) den
  3032. # Defaultwert fⁿr jede MERGE-Operation. Dies ist derjenige, den das System
  3033. # in vom Benutzer eingegebene Pathnames "hineininterpretiert".
  3034. # Er wird auf dem neuesten Stand des DEFAULT_DRIVE gehalten: bei der
  3035. # Initialisierung das aktuelle Device (im Sinne von DOS), bei der
  3036. # ─nderung von DEFAULT_DRIVE mittels CD.
  3037.  
  3038. #endif # PATHNAME_MSDOS || PATHNAME_OS2
  3039.  
  3040. #if defined(PATHNAME_UNIX) || defined(PATHNAME_AMIGAOS)
  3041.  
  3042. # Die Variable *DEFAULT-PATHNAME-DEFAULTS* enthΣlt (als Pathname) den
  3043. # Defaultwert fⁿr jede MERGE-Operation. Dies ist derjenige, den das System
  3044. # in vom Benutzer eingegebene Pathnames "hineininterpretiert".
  3045.  
  3046. #endif
  3047.  
  3048. #ifdef UNIX
  3049.  
  3050. # Das Betriebssystem verwaltet ein Default-Directory ("working directory")
  3051. # fⁿr diesen Proze▀. Es kann mit chdir verΣndert und mit getwd abgefragt
  3052. # werden. Siehe CHDIR(2) und GETWD(3).
  3053.  
  3054. #endif
  3055.  
  3056. #ifdef AMIGAOS
  3057.  
  3058. # Das Betriebssystem verwaltet ein Default-Directory ("current directory")
  3059. # fⁿr diesen Proze▀. Es kann mit CurrentDir verΣndert und mit einer
  3060. # Kombination aus Examine und ParentDir abgefragt werden.
  3061.  
  3062. #endif
  3063.  
  3064. # UP: Neuberechnung von *DEFAULT-PATHNAME-DEFAULTS*
  3065. #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  3066. # aus DEFAULT_DRIVE
  3067. #endif
  3068. # recalc_defaults_pathname();
  3069. # < ergebnis: Wert von *DEFAULT-PATHNAME-DEFAULTS*, ein Pathname
  3070. # kann GC ausl÷sen
  3071.   local object recalc_defaults_pathname (void);
  3072.   local object recalc_defaults_pathname()
  3073.     {
  3074.       #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  3075.       # (MAKE-PATHNAME :DEVICE default-drive) ausfⁿhren:
  3076.       pushSTACK(S(Kdevice)); pushSTACK(O(default_drive));
  3077.       funcall(L(make_pathname),2);
  3078.       #endif
  3079.       #if defined(PATHNAME_UNIX) || defined(PATHNAME_AMIGAOS) || defined(PATHNAME_RISCOS)
  3080.       # (MAKE-PATHNAME) ausfⁿhren:
  3081.       funcall(L(make_pathname),0);
  3082.       #endif
  3083.       # und *DEFAULT-PATHNAME-DEFAULTS* zuweisen:
  3084.       return Symbol_value(S(default_pathname_defaults)) = value1;
  3085.     }
  3086.  
  3087. # UP: Liefert den Default-Pathname.
  3088. # defaults_pathname()
  3089. # < ergebnis: Wert von *DEFAULT-PATHNAME-DEFAULTS*, ein Pathname
  3090. # kann GC ausl÷sen
  3091.   local object defaults_pathname (void);
  3092.   local object defaults_pathname()
  3093.     { var reg1 object pathname = Symbol_value(S(default_pathname_defaults)); # Wert von *DEFAULT-PATHNAME-DEFAULTS*
  3094.       if (pathnamep(pathname))
  3095.         # ist Pathname -> OK
  3096.         { return pathname; }
  3097.         else
  3098.         # sonst Warnung:
  3099.         { # (WARN "Der Wert von ~S war kein Pathname. ~:*~S wird zurⁿckgesetzt." ...)
  3100.           pushSTACK(OL(defaults_warn_string));
  3101.           pushSTACK(S(default_pathname_defaults));
  3102.           funcall(S(warn),2);
  3103.           # und neuberechnen:
  3104.           return recalc_defaults_pathname();
  3105.     }   }
  3106.  
  3107. LISPFUN(merge_pathnames,1,2,norest,key,1, (kw(wild)))
  3108. # (MERGE-PATHNAMES pathname [defaults [default-version]] [:wild]), CLTL S. 415
  3109. # (defun merge-pathnames (pathname &optional (defaults *default-pathname-defaults*) default-version)
  3110. #   (setq pathname (pathname pathname))
  3111. #   (setq defaults (pathname defaults))
  3112. #   (multiple-value-call #'make-pathname
  3113. #if HAS_HOST
  3114. #     (if (or (equal (pathname-host pathname) (pathname-host defaults))
  3115. #             (null (pathname-host pathname))
  3116. #         )
  3117. #       (values
  3118. #         :host (or (pathname-host pathname) (pathname-host defaults))
  3119. #endif
  3120. #if HAS_DEVICE
  3121. #     (if (or (equal (pathname-device pathname) (pathname-device defaults))
  3122. #             (null (pathname-device pathname))
  3123. #         )
  3124. #       (values
  3125. #         :device (or (pathname-device pathname) (pathname-device defaults))
  3126. #endif
  3127. #         :directory
  3128. #           (let ((pathname-dir (pathname-directory pathname))
  3129. #                 (defaults-dir (pathname-directory defaults)))
  3130. #if HAS_SERNR
  3131. #             (if (or (eql (car pathname-dir) (car defaults-dir))
  3132. #                     (null (car pathname-dir))
  3133. #                 )
  3134. #               (cons (or (car pathname-dir) (car defaults-dir))
  3135. #                 (progn (pop pathname-dir) (pop defaults-dir)
  3136. #endif
  3137. #                   (if (eq (car pathname-dir) ':RELATIVE)
  3138. #                     (cond ((null (cdr pathname-dir)) defaults-dir)
  3139. #                           ((not (eq (car defaults-dir) ':RELATIVE))
  3140. #                            (append defaults-dir (cdr pathname-dir))
  3141. #                           )
  3142. #                           (t pathname-dir)
  3143. #                     )
  3144. #                     pathname-dir
  3145. #                   )
  3146. #if HAS_SERNR
  3147. #               ) )
  3148. #               pathname-dir
  3149. #             )
  3150. #endif
  3151. #           )
  3152. #       )
  3153. #       (values
  3154. #if HAS_HOST
  3155. #         :host (pathname-host pathname)
  3156. #endif
  3157. #if HAS_DEVICE
  3158. #         :device (pathname-device pathname)
  3159. #endif
  3160. #         :directory (pathname-directory pathname)
  3161. #     ) )
  3162. #     :name (or (pathname-name pathname) (pathname-name defaults))
  3163. #     :type (or (pathname-type pathname) (pathname-type defaults))
  3164. # ) )
  3165. # Ist das :WILD-Argument angegeben, werden statt fehlenden Komponenten
  3166. # :WILD-Komponenten ersetzt.
  3167.   { var reg10 boolean wildp = !(eq(STACK_0,unbound) || nullp(STACK_0));
  3168.     skipSTACK(1);
  3169.     # default-version ⁿberprⁿfen:
  3170.     #if HAS_VERSION || defined(LOGICAL_PATHNAMES)
  3171.     {var reg9 object v = test_optional_version(S(Knewest)); # Default ist :NEWEST
  3172.      STACK_0 = STACK_1; STACK_1 = STACK_2; STACK_2 = v;
  3173.     }# Stackaufbau: default-version, pathname, defaults.
  3174.     #else
  3175.      test_optional_version(S(Knewest)); skipSTACK(1);
  3176.      # Stackaufbau: pathname, defaults.
  3177.     #endif
  3178.     # pathname und defaults ⁿberprⁿfen:
  3179.     # defaults zu einem Pathname machen:
  3180.     STACK_0 = test_default_pathname(STACK_0);
  3181.     # pathname zu einem Pathname machen:
  3182.     #ifdef LOGICAL_PATHNAMES
  3183.     if (logpathnamep(STACK_0))
  3184.       { if (!xpathnamep(STACK_1))
  3185.           { pushSTACK(subr_self); # subr_self retten (fⁿr spΣtere Fehlermeldungen)
  3186.             # Das Ergebnis von (PARSE-NAMESTRING obj nil empty-logical-pathname)
  3187.             # ist garantiert ein logischer Pathname.
  3188.             pushSTACK(STACK_(1+1)); pushSTACK(NIL); pushSTACK(O(empty_logical_pathname));
  3189.             funcall(L(parse_namestring),3);
  3190.             subr_self = popSTACK();
  3191.             STACK_1 = value1;
  3192.       }   }
  3193.       else
  3194.     #endif
  3195.       { STACK_1 = coerce_xpathname(STACK_1); }
  3196.     #ifdef LOGICAL_PATHNAMES
  3197.     if (logpathnamep(STACK_1) && logpathnamep(STACK_0))
  3198.       # MERGE-PATHNAMES fⁿr Logical Pathnames
  3199.       { var reg6 object new = allocate_logpathname(); # neuen Pathname holen
  3200.         var reg8 object d = popSTACK(); # defaults
  3201.         var reg7 object p = popSTACK(); # pathname
  3202.         # Hosts matchen:
  3203.         { var reg1 object p_host = TheLogpathname(p)->pathname_host;
  3204.           var reg2 object d_host = TheLogpathname(d)->pathname_host;
  3205.           TheLogpathname(new)->pathname_host = p_host; # erstmal new-host := pathname-host
  3206.           if (equal(p_host,d_host)) goto lmatch_directories;
  3207.           if (wildp ? FALSE : nullp(p_host))
  3208.             { # pathname-host nicht angegeben, aber defaults-host angegeben:
  3209.               TheLogpathname(new)->pathname_host = d_host; # new-host := defaults-host
  3210.               goto lmatch_directories;
  3211.         }   }
  3212.         # Directories nicht matchen:
  3213.         { # new-directory := pathname-directory :
  3214.           TheLogpathname(new)->pathname_directory = TheLogpathname(p)->pathname_directory;
  3215.         }
  3216.         goto ldirectories_OK;
  3217.         lmatch_directories:
  3218.         # Directories matchen:
  3219.         { var reg2 object p_directory = TheLogpathname(p)->pathname_directory; # pathname-directory
  3220.           var reg3 object d_directory = TheLogpathname(d)->pathname_directory; # defaults-directory
  3221.          {var reg4 object new_subdirs = p_directory;
  3222.       # FΣngt pathname-subdirs mit :RELATIVE an?
  3223.           if (!wildp && eq(Car(p_directory),S(Krelative)))
  3224.             # ja.
  3225.             { # Endet pathname-subdirs danach?
  3226.               if (matomp(Cdr(p_directory)))
  3227.                 # ja -> verwende defaults-subdirs:
  3228.                 { new_subdirs = d_directory; }
  3229.                 else
  3230.                 # nein.
  3231.                 { # FΣngt defaults-subdirs mit :RELATIVE an?
  3232.                   if (eq(Car(d_directory),S(Krelative)))
  3233.                     # ja -> Ersetzen von :RELATIVE in pathname-subdirs
  3234.                     # durch das gesamte defaults-subdirs ist nicht sinnvoll
  3235.                     # (da nicht klar ist, auf was das dabei entstehende
  3236.                     # Default-Directory sich beziehen soll). Daher nichts tun:
  3237.                     {}
  3238.                     else
  3239.                     # nein -> Um :RELATIVE aufzul÷sen: ersetze :RELATIVE
  3240.                     # in pathname-subdirs durch defaults-subdirs, d.h.
  3241.                     # bilde (append defaults-subdirs (cdr pathname-subdirs)) =
  3242.                     # (nreconc (reverse defaults-subdirs) (cdr pathname-subdirs)) :
  3243.                     { pushSTACK(p); pushSTACK(d); pushSTACK(new);
  3244.                       pushSTACK(Cdr(p_directory));
  3245.                       {var reg1 object temp = reverse(d_directory);
  3246.                        new_subdirs = nreconc(temp,popSTACK());
  3247.                       }
  3248.                       new = popSTACK(); d = popSTACK(); p = popSTACK();
  3249.                     }
  3250.             }   }
  3251.           TheLogpathname(new)->pathname_directory = new_subdirs; # new-directory := new-subdirs
  3252.         }}
  3253.         ldirectories_OK:
  3254.         # Nun sind die Directories OK.
  3255.         # Name matchen:
  3256.         # Verwende pathname-name, falls angegeben, und defaults-name sonst.
  3257.         { var reg1 object p_name = TheLogpathname(p)->pathname_name;
  3258.           TheLogpathname(new)->pathname_name =
  3259.             (!(wildp ? eq(p_name,S(Kwild)) : nullp(p_name))
  3260.              ? p_name
  3261.              : TheLogpathname(d)->pathname_name
  3262.             );
  3263.         }
  3264.         # Typ matchen:
  3265.         # Verwende pathname-type, falls angegeben, und defaults-type sonst.
  3266.         { var reg1 object p_type = TheLogpathname(p)->pathname_type;
  3267.           TheLogpathname(new)->pathname_type =
  3268.             (!(wildp ? eq(p_type,S(Kwild)) : nullp(p_type))
  3269.              ? p_type
  3270.              : TheLogpathname(d)->pathname_type
  3271.             );
  3272.         }
  3273.         # Version matchen:
  3274.         # Verwende pathname-version, falls angegeben, und default-version sonst.
  3275.         { var reg1 object p_version = TheLogpathname(p)->pathname_version;
  3276.           TheLogpathname(new)->pathname_version =
  3277.             (!(wildp ? eq(p_version,S(Kwild)) : nullp(p_version))
  3278.              ? p_version
  3279.              : STACK_0
  3280.             );
  3281.           skipSTACK(1);
  3282.         }
  3283.         # new als Wert:
  3284.         value1 = new; mv_count=1;
  3285.         return;
  3286.       }
  3287.     # nicht beides logische Pathnames -> erst in normale Pathnames umwandeln:
  3288.     STACK_1 = coerce_pathname(STACK_1);
  3289.     STACK_0 = coerce_pathname(STACK_0);
  3290.     #endif
  3291.    {var reg6 object new = allocate_pathname(); # neuen Pathname holen
  3292.     var reg8 object d = popSTACK(); # defaults
  3293.     var reg7 object p = popSTACK(); # pathname
  3294.     #if HAS_HOST
  3295.     # Hosts matchen:
  3296.     { var reg1 object p_host = ThePathname(p)->pathname_host;
  3297.       var reg2 object d_host = ThePathname(d)->pathname_host;
  3298.       ThePathname(new)->pathname_host = p_host; # erstmal new-host := pathname-host
  3299.       # beide Hosts gleich -> Devices matchen:
  3300.       if (equal(p_host,d_host)) goto match_devices;
  3301.       if (wildp ? FALSE : nullp(p_host))
  3302.         { # pathname-host nicht angegeben, aber defaults-host angegeben:
  3303.           ThePathname(new)->pathname_host = d_host; # new-host := defaults-host
  3304.           goto match_devices;
  3305.         }
  3306.       goto notmatch_devices;
  3307.     }
  3308.     #endif
  3309.     match_devices:
  3310.     #if HAS_DEVICE
  3311.     # Devices matchen:
  3312.     { var reg1 object p_device = ThePathname(p)->pathname_device;
  3313.       var reg2 object d_device = ThePathname(d)->pathname_device;
  3314.       ThePathname(new)->pathname_device = p_device; # erstmal new-device := pathname-device
  3315.       # beide Devices gleich -> Directories matchen:
  3316.       if (equal(p_device,d_device)) goto match_directories;
  3317.       if (wildp ? eq(p_device,S(Kwild)) : nullp(p_device))
  3318.         { # pathname-device nicht angegeben, aber defaults-device angegeben:
  3319.           ThePathname(new)->pathname_device = d_device; # new-device := defaults-device
  3320.           goto match_directories;
  3321.         }
  3322.       goto notmatch_directories;
  3323.     }
  3324.     #endif
  3325.     # Directories matchen:
  3326.     match_directories:
  3327.     { var reg2 object p_directory = ThePathname(p)->pathname_directory; # pathname-directory
  3328.       var reg3 object d_directory = ThePathname(d)->pathname_directory; # defaults-directory
  3329.       #if HAS_SERNR
  3330.       var reg5 object new_seriennummer = Car(p_directory); # pathname-Seriennummer
  3331.       # beide Seriennummern gleich -> Subdirectories matchen:
  3332.       if (eq(Car(p_directory),Car(d_directory))) goto match_subdirs;
  3333.       if (nullp(Car(p_directory)))
  3334.         { # pathname-Seriennummer nicht angegeben, aber defaults-Seriennummer angegeben:
  3335.           new_seriennummer = Car(d_directory); # new-Seriennummer := defaults-Seriennummer
  3336.           goto match_subdirs;
  3337.         }
  3338.       goto notmatch_directories;
  3339.       # Subdirectories matchen:
  3340.       match_subdirs:
  3341.       p_directory = Cdr(p_directory); # pathname-subdirs = (cdr pathname-directory)
  3342.       d_directory = Cdr(d_directory); # defaults-subdirs = (cdr defaults-directory)
  3343.       #endif
  3344.      {var reg4 object new_subdirs = p_directory;
  3345.       # FΣngt pathname-subdirs mit :RELATIVE an?
  3346.       if (!wildp && eq(Car(p_directory),S(Krelative)))
  3347.         # ja.
  3348.         { # Endet pathname-subdirs danach?
  3349.           if (matomp(Cdr(p_directory)))
  3350.             # ja -> verwende defaults-subdirs:
  3351.             { new_subdirs = d_directory; }
  3352.             else
  3353.             # nein.
  3354.             { # FΣngt defaults-subdirs mit :RELATIVE an?
  3355.               if (eq(Car(d_directory),S(Krelative)))
  3356.                 # ja -> Ersetzen von :RELATIVE in pathname-subdirs
  3357.                 # durch das gesamte defaults-subdirs ist nicht sinnvoll
  3358.                 # (da nicht klar ist, auf was das dabei entstehende
  3359.                 # Default-Directory sich beziehen soll). Daher nichts tun:
  3360.                 {}
  3361.                 else
  3362.                 # nein -> Um :RELATIVE aufzul÷sen: ersetze :RELATIVE
  3363.                 # in pathname-subdirs durch defaults-subdirs, d.h.
  3364.                 # bilde (append defaults-subdirs (cdr pathname-subdirs)) =
  3365.                 # (nreconc (reverse defaults-subdirs) (cdr pathname-subdirs)) :
  3366.                 { pushSTACK(p); pushSTACK(d); pushSTACK(new);
  3367.                   #if HAS_SERNR
  3368.                   pushSTACK(new_seriennummer);
  3369.                   #endif
  3370.                   pushSTACK(Cdr(p_directory));
  3371.                   {var reg1 object temp = reverse(d_directory);
  3372.                    new_subdirs = nreconc(temp,popSTACK());
  3373.                   }
  3374.                   #if HAS_SERNR
  3375.                   new_seriennummer = popSTACK();
  3376.                   #endif
  3377.                   new = popSTACK(); d = popSTACK(); p = popSTACK();
  3378.                 }
  3379.         }   }
  3380.       #if HAS_SERNR
  3381.       # new-directory aus new-Seriennummer und new-subdirs zusammensetzen:
  3382.       { pushSTACK(p); pushSTACK(d); pushSTACK(new);
  3383.         pushSTACK(new_seriennummer); pushSTACK(new_subdirs);
  3384.        {var reg1 object new_cons = allocate_cons(); # neues Cons
  3385.         Cdr(new_cons) = popSTACK(); Car(new_cons) = popSTACK();
  3386.         # new_cons = (cons new-Seriennummer new-subdirs)
  3387.         new = popSTACK(); d = popSTACK(); p = popSTACK();
  3388.         new_subdirs = new_cons;
  3389.       }}
  3390.       #endif
  3391.       ThePathname(new)->pathname_directory = new_subdirs; # new-directory := new-subdirs
  3392.     }}
  3393.     goto directories_OK;
  3394.     # Devices nicht matchen:
  3395.     notmatch_devices:
  3396.     #if HAS_DEVICE
  3397.     { # new-device := pathname-device :
  3398.       ThePathname(new)->pathname_device = ThePathname(p)->pathname_device;
  3399.     }
  3400.     #endif
  3401.     # Directories nicht matchen:
  3402.     notmatch_directories:
  3403.     { # new-directory := pathname-directory :
  3404.       ThePathname(new)->pathname_directory = ThePathname(p)->pathname_directory;
  3405.     }
  3406.     directories_OK:
  3407.     # Nun sind die Directories OK.
  3408.     # Name matchen:
  3409.     # Verwende pathname-name, falls angegeben, und defaults-name sonst.
  3410.     { var reg1 object p_name = ThePathname(p)->pathname_name;
  3411.       ThePathname(new)->pathname_name =
  3412.         (!(wildp ?
  3413.            #ifdef PATHNAME_EXT83
  3414.            eq(p_name,S(Kwild))
  3415.            #else # PATHNAME_NOEXT || PATHNAME_RISCOS
  3416.            equal(p_name,O(wild_string))
  3417.            #endif
  3418.            : nullp(p_name)
  3419.           )
  3420.          ? p_name
  3421.          : ThePathname(d)->pathname_name
  3422.         );
  3423.     }
  3424.     # Typ matchen:
  3425.     # Verwende pathname-type, falls angegeben, und defaults-type sonst.
  3426.     { var reg1 object p_type = ThePathname(p)->pathname_type;
  3427.       ThePathname(new)->pathname_type =
  3428.         (!(wildp ?
  3429.            #ifdef PATHNAME_EXT83
  3430.            eq(p_type,S(Kwild))
  3431.            #else # PATHNAME_NOEXT || PATHNAME_RISCOS
  3432.            equal(p_type,O(wild_string))
  3433.            #endif
  3434.            : nullp(p_type)
  3435.           )
  3436.          ? p_type
  3437.          : ThePathname(d)->pathname_type
  3438.         );
  3439.     }
  3440.     #if HAS_VERSION
  3441.     # Version matchen:
  3442.     # Verwende pathname-version, falls angegeben, und default-version sonst.
  3443.     { var reg1 object p_version = ThePathname(p)->pathname_version;
  3444.       ThePathname(new)->pathname_version =
  3445.         (!(wildp ? eq(p_version,S(Kwild)) : nullp(p_version))
  3446.          ? p_version
  3447.          : STACK_0
  3448.         );
  3449.     }
  3450.     #endif
  3451.     #if HAS_VERSION || defined(LOGICAL_PATHNAMES)
  3452.     skipSTACK(1);
  3453.     #endif
  3454.     # new als Wert:
  3455.     value1 = new; mv_count=1;
  3456.   }}
  3457.  
  3458. LISPFUN(enough_namestring,1,1,norest,nokey,0,NIL)
  3459. # (ENOUGH-NAMESTRING pathname [defaults]), CLTL S. 417
  3460. # (defun enough-namestring (pathname &optional (defaults *default-pathname-defaults*))
  3461. #   (setq pathname (pathname pathname))
  3462. #   (setq defaults (pathname defaults))
  3463. #   (namestring
  3464. #     (multiple-value-call #'make-pathname
  3465. #if HAS_HOST
  3466. #       (if (equal (pathname-host pathname) (pathname-host defaults))
  3467. #         (values
  3468. #           :host nil
  3469. #endif
  3470. #if HAS_DEVICE
  3471. #       (if (equal (pathname-device pathname) (pathname-device defaults))
  3472. #         (values
  3473. #           :device nil
  3474. #endif
  3475. #           :directory
  3476. #             (let ((pathname-dir (pathname-directory pathname))
  3477. #                   (defaults-dir (pathname-directory defaults)))
  3478. #if HAS_SERNR
  3479. #               (if (equal (car pathname-dir) (car defaults-dir))
  3480. #                 (cons nil
  3481. #                   (progn (pop pathname-dir) (pop defaults-dir)
  3482. #endif
  3483. #                     (if (equal pathname-dir defaults-dir)
  3484. #                       (list ':RELATIVE)
  3485. #                       (if (and (not (eq (car pathname-dir) ':RELATIVE))
  3486. #                                (not (eq (car defaults-dir) ':RELATIVE))
  3487. #                                (equal (subseq pathname-dir 0 (min (length pathname-dir) (length defaults-dir)))
  3488. #                                       defaults-dir
  3489. #                           )    )
  3490. #                         (cons ':RELATIVE (nthcdr (length defaults-dir) pathname-dir))
  3491. #                         pathname-dir
  3492. #                     ) )
  3493. #if HAS_SERNR
  3494. #                 ) )
  3495. #                 pathname-dir
  3496. #               )
  3497. #endif
  3498. #             )
  3499. #         )
  3500. #         (values
  3501. #if HAS_HOST
  3502. #           :host (pathname-host pathname)
  3503. #endif
  3504. #if HAS_DEVICE
  3505. #           :device (pathname-device pathname)
  3506. #endif
  3507. #           :directory (pathname-directory pathname)
  3508. #       ) )
  3509. #       :name (if (equal (pathname-name pathname) (pathname-name defaults))
  3510. #               nil
  3511. #               (pathname-name pathname)
  3512. #             )
  3513. #       :type (if (equal (pathname-type pathname) (pathname-type defaults))
  3514. #               nil
  3515. #               (pathname-type pathname)
  3516. #             )
  3517. # ) ) )
  3518.   { # pathname und defaults ⁿberprⁿfen:
  3519.     # pathname zu einem Pathname machen:
  3520.     STACK_1 = coerce_pathname(STACK_1);
  3521.     # defaults zu einem Pathname machen:
  3522.     STACK_0 = coerce_pathname(test_default_pathname(STACK_0));
  3523.     # neuen Pathname holen:
  3524.    {var reg6 object new = allocate_pathname();
  3525.     pushSTACK(new);
  3526.     # Stackaufbau: pathname, defaults, new.
  3527.     #if HAS_HOST
  3528.     # Hosts vergleichen:
  3529.     { var reg7 object p_host = ThePathname(STACK_2)->pathname_host; # pathname-host
  3530.       var reg8 object d_host = ThePathname(STACK_1)->pathname_host; # defaults-host
  3531.       if (equal(p_host,d_host)) # beide Hosts gleich ?
  3532.         # ja.
  3533.         { ThePathname(new)->pathname_host = NIL; # new-host := NIL
  3534.     #endif
  3535.     #if HAS_DEVICE
  3536.     # Devices vergleichen:
  3537.     { var reg7 object p_device = ThePathname(STACK_2)->pathname_device; # pathname-device
  3538.       var reg8 object d_device = ThePathname(STACK_1)->pathname_device; # defaults-device
  3539.       if (equal(p_device,d_device)) # beide Devices gleich ?
  3540.         # ja.
  3541.         { ThePathname(new)->pathname_device = NIL; # new-device := NIL
  3542.     #endif
  3543.          {var reg3 object p_directory = ThePathname(STACK_2)->pathname_directory; # pathname-directory
  3544.           var reg4 object d_directory = ThePathname(STACK_1)->pathname_directory; # defaults-directory
  3545.           #if HAS_SERNR
  3546.           if (eq(Car(p_directory),Car(d_directory))) # gleiche Seriennummern ?
  3547.             # ja -> verwende NIL als Seriennummer
  3548.             { p_directory = Cdr(p_directory); # pathname-subdirs
  3549.               d_directory = Cdr(d_directory); # defaults-subdirs
  3550.           #endif
  3551.              {var reg5 object new_subdirs;
  3552.               # vergleiche pathname-subdirs und defaults-subdirs:
  3553.               if (equal(p_directory,d_directory))
  3554.                 # gleich -> verwende (cons :RELATIVE nil) :
  3555.                 { new_subdirs = NIL; goto insert_RELATIVE; }
  3556.                 else
  3557.                 { # FΣngt weder pathname-subdirs noch defaults-subdirs
  3558.                   # mit :RELATIVE an?
  3559.                   if (   (!eq(Car(p_directory),S(Krelative)))
  3560.                       && (!eq(Car(d_directory),S(Krelative)))
  3561.                      )
  3562.                     # ja -> testen, ob defaults-subdirs ein Anfangsstⁿck
  3563.                     # der Liste pathname-subdirs ist:
  3564.                     { var reg1 object Lp = p_directory;
  3565.                       var reg2 object Ld = d_directory;
  3566.                       # Ist Ld ein Anfangsstⁿck von Lp ?
  3567.                       loop
  3568.                         { if (atomp(Ld)) # Ld zu Ende -> ja
  3569.                             { new_subdirs = Lp; goto insert_RELATIVE; }
  3570.                           if (atomp(Lp)) break; # Lp zu Ende -> nein
  3571.                           if (!equal(Car(Ld),Car(Lp))) # verschiedene Listenelemente?
  3572.                             break; # -> nein
  3573.                           Ld = Cdr(Ld); Lp = Cdr(Lp); # Listen weiterrⁿcken
  3574.                         }
  3575.                     }
  3576.                   new_subdirs = p_directory; # new-subdirs := pathname-subdirs
  3577.                   goto subdirs_ok;
  3578.                 }
  3579.               insert_RELATIVE:
  3580.               # new-subdirs := (cons :RELATIVE new-subdirs) :
  3581.               { pushSTACK(new_subdirs);
  3582.                 new_subdirs = allocate_cons();
  3583.                 Cdr(new_subdirs) = popSTACK(); Car(new_subdirs) = S(Krelative);
  3584.               }
  3585.               subdirs_ok: # new-subdirs ist die neue Subdir-Liste.
  3586.               #if HAS_SERNR
  3587.               # new-subdirs := (cons NIL new-subdirs) :
  3588.               { pushSTACK(new_subdirs);
  3589.                {var reg1 object new_cons = allocate_cons();
  3590.                 Cdr(new_cons) = popSTACK();
  3591.                 new_subdirs = new_cons;
  3592.               }}
  3593.               #endif
  3594.               # new-directory := new-subdirs :
  3595.               ThePathname(new=STACK_0)->pathname_directory = new_subdirs;
  3596.              }
  3597.             #if HAS_SERNR
  3598.             }
  3599.             else
  3600.             # verschiedene Seriennummern -> new-directory := pathname-directory :
  3601.             { ThePathname(new)->pathname_directory = p_directory; }
  3602.             #endif
  3603.          }
  3604.     #if HAS_DEVICE
  3605.         }
  3606.         else
  3607.         # verschiedene Devices
  3608.         { # new-device := pathname-device :
  3609.           ThePathname(new)->pathname_device = p_device;
  3610.           # new-directory := pathname-directory :
  3611.           ThePathname(new)->pathname_directory = ThePathname(STACK_2)->pathname_directory;
  3612.         }
  3613.     }
  3614.     #endif
  3615.     #if HAS_HOST
  3616.         }
  3617.         else
  3618.         # verschiedene Hosts
  3619.         { # new-host := pathname-host :
  3620.           ThePathname(new)->pathname_host = p_host;
  3621.           #if HAS_DEVICE
  3622.           # new-device := pathname-device :
  3623.           ThePathname(new)->pathname_device = ThePathname(STACK_2)->pathname_device;
  3624.           #endif
  3625.           # new-directory := pathname-directory :
  3626.           ThePathname(new)->pathname_directory = ThePathname(STACK_2)->pathname_directory;
  3627.         }
  3628.     }
  3629.     #endif
  3630.     # name einfⁿllen:
  3631.     { var reg1 object p_name = ThePathname(STACK_2)->pathname_name; # pathname-name
  3632.       var reg2 object d_name = ThePathname(STACK_1)->pathname_name; # defaults-name
  3633.       ThePathname(new)->pathname_name = (equal(p_name,d_name) ? NIL : p_name);
  3634.     }
  3635.     # type einfⁿllen:
  3636.     { var reg1 object p_type = ThePathname(STACK_2)->pathname_type; # pathname-type
  3637.       var reg2 object d_type = ThePathname(STACK_1)->pathname_type; # defaults-type
  3638.       ThePathname(new)->pathname_type = (equal(p_type,d_type) ? NIL : p_type);
  3639.     }
  3640.     skipSTACK(3);
  3641.     # (namestring new) bilden:
  3642.     value1 = whole_namestring(new); mv_count=1;
  3643.   }}
  3644.  
  3645. #ifdef LOGICAL_PATHNAMES
  3646.  
  3647. # UP: ▄berprⁿft, ob object ein zulΣssiger Name ist:
  3648. # :WILD oder ein Simple-String aus gⁿltigen Zeichen, keine adjazenten '*'.
  3649. # legal_logical_word(object)
  3650.   local boolean legal_logical_word (object obj);
  3651.   local boolean legal_logical_word(obj)
  3652.     var reg5 object obj;
  3653.     { if (eq(obj,S(Kwild))) { return TRUE; }
  3654.       if (!simple_string_p(obj)) { return FALSE; }
  3655.      {var reg3 uintL len = TheSstring(obj)->length;
  3656.       if (len==0) { return FALSE; } # leeres Word ist verboten
  3657.       {var reg2 uintB* charptr = &TheSstring(obj)->data[0];
  3658.        var reg4 boolean last_was_star = FALSE;
  3659.        dotimespL(len,len,
  3660.          { var reg1 uintB ch = *charptr++;
  3661.            if (!(legal_logical_word_char(ch) || (ch=='*'))) { return FALSE; }
  3662.            if (ch=='*')
  3663.              { if (last_was_star) return FALSE; # adjazente '*' sind verboten
  3664.                last_was_star = TRUE;
  3665.              }
  3666.              else
  3667.              { last_was_star = FALSE; }
  3668.          });
  3669.        return TRUE;
  3670.     }}}
  3671.  
  3672. #endif
  3673.  
  3674. #ifdef PATHNAME_EXT83
  3675.  
  3676. # UP: ▄berprⁿft, ob object ein zulΣssiger Name oder Typ ist: :WILD oder
  3677. # ein Simple-String mit max. stdlen Zeichen, alle alphabetisch und Up-case.
  3678. # legal_name_or_type(object,stdlen)
  3679.   local boolean legal_name_or_type (object obj, uintL stdlen);
  3680.   local boolean legal_name_or_type(obj,stdlen)
  3681.     var reg3 object obj;
  3682.     var reg4 uintL stdlen;
  3683.     { if (eq(obj,S(Kwild))) { return TRUE; } # :WILD ist OK
  3684.       if (!simple_string_p(obj)) { return FALSE; } # sonst: Simple-String ?
  3685.      {var reg2 uintL len = TheSstring(obj)->length;
  3686.       #ifndef EMUNIX_PORTABEL
  3687.       if (!(len <= stdlen)) { return FALSE; } # und LΣnge <=stdlen ?
  3688.       #endif
  3689.       # Jedes einzelne Zeichen ⁿberprⁿfen:
  3690.       {var reg1 uintB* ptr = &TheSstring(obj)->data[0];
  3691.        dotimesL(len,len,
  3692.          { var reg1 uintB ch = *ptr++;
  3693.            if (!(legal_namechar(ch) # zulΣssiges Zeichen ?
  3694.                  && (up_case(ch)==ch) # und Gro▀buchstabe ?
  3695.               ) )
  3696.              { return FALSE; }
  3697.          });
  3698.       }
  3699.       return TRUE;
  3700.     }}
  3701.  
  3702. # UP: ▄berprⁿft, ob object ein zulΣssiger Name ist: :WILD oder
  3703. # ein Simple-String mit max. 8 Zeichen, alle alphabetisch und Up-case.
  3704. # legal_name(object)
  3705.   #define legal_name(obj)  legal_name_or_type(obj,8)
  3706.  
  3707. # UP: ▄berprⁿft, ob object ein zulΣssiger Typ ist: :WILD oder
  3708. # ein Simple-String mit max. 3 Zeichen, alle alphabetisch und Up-case.
  3709. # legal_type(object)
  3710.   #define legal_type(obj)  legal_name_or_type(obj,3)
  3711.  
  3712. #endif # PATHNAME_EXT83
  3713.  
  3714. #if defined(PATHNAME_NOEXT) || defined(PATHNAME_RISCOS)
  3715.  
  3716. # UP: ▄berprⁿft, ob object ein zulΣssiger Name ist:
  3717. # ein Simple-String aus gⁿltigen Zeichen
  3718. # legal_name(object)
  3719.   local boolean legal_name (object obj);
  3720.   local boolean legal_name(obj)
  3721.     var reg3 object obj;
  3722.     { if (!simple_string_p(obj)) { return FALSE; }
  3723.      {var reg2 uintL len = TheSstring(obj)->length;
  3724.       var reg1 uintB* charptr = &TheSstring(obj)->data[0];
  3725.       dotimesL(len,len, { if (!legal_namechar(*charptr++)) { return FALSE; } } );
  3726.       return TRUE;
  3727.     }}
  3728.  
  3729. # UP: ▄berprⁿft, ob object ein zulΣssiger Name ist:
  3730. # ein Simple-String aus gⁿltigen Zeichen, ohne '.'
  3731. # legal_type(object)
  3732.   local boolean legal_type (object obj);
  3733. #ifdef PATHNAME_NOEXT
  3734.   local boolean legal_type(obj)
  3735.     var reg4 object obj;
  3736.     { if (!simple_string_p(obj)) { return FALSE; }
  3737.      {var reg3 uintL len = TheSstring(obj)->length;
  3738.       var reg2 uintB* charptr = &TheSstring(obj)->data[0];
  3739.       dotimesL(len,len,
  3740.         { var reg1 uintB ch = *charptr++;
  3741.           if ((ch=='.') || (!legal_namechar(ch))) { return FALSE; }
  3742.         });
  3743.       return TRUE;
  3744.     }}
  3745. #endif
  3746. #ifdef PATHNAME_RISCOS
  3747.   #define legal_type(obj)  legal_name(obj)
  3748. #endif
  3749.  
  3750. #endif # PATHNAME_NOEXT || PATHNAME_RISCOS
  3751.  
  3752. LISPFUN(make_pathname,0,0,norest,key,8,\
  3753.         (kw(defaults),kw(case),kw(host),kw(device),kw(directory),kw(name),kw(type),kw(version)) )
  3754. # (MAKE-PATHNAME [:host] [:device] [:directory] [:name] [:type] [:version]
  3755. #                [:defaults] [:case]),
  3756. # CLTL S. 416, CLtL2 S. 643
  3757.   # Stackaufbau: defaults, case, host, device, directory, name, type, version.
  3758.   { var reg5 boolean logical = FALSE;
  3759.     var reg4 boolean convert = eq(STACK_6,S(Kcommon));
  3760.     # 1. host ⁿberprⁿfen:
  3761.     #ifdef LOGICAL_PATHNAMES
  3762.     # Damit TRANSLATE-PATHNAMES logische Pathnames erzeugen kann:
  3763.     if (logpathnamep(STACK_5))
  3764.       { STACK_5 = TheLogpathname(STACK_5)->pathname_host;
  3765.         logical = TRUE; convert = FALSE;
  3766.       }
  3767.     #endif
  3768.     #if HAS_HOST
  3769.     STACK_5 = test_optional_host(STACK_5,convert);
  3770.     #else
  3771.     STACK_5 = test_optional_host(STACK_5);
  3772.     #endif
  3773.     #ifdef LOGICAL_PATHNAMES
  3774.     if (!nullp(STACK_5) && logical_host_p(STACK_5))
  3775.       { logical = TRUE; convert = FALSE; STACK_5 = string_upcase(STACK_5); }
  3776.     #endif
  3777.     # 2. device ⁿberprⁿfen:
  3778.     #if HAS_DEVICE
  3779.     { var reg1 object device = STACK_4;
  3780.       if (eq(device,unbound)) # angegeben ?
  3781.         { STACK_4 = NIL; } # nein -> verwende NIL
  3782.         else
  3783.         { if (convert) { STACK_4 = device = common_case(device); }
  3784.           if (nullp(device)) goto device_ok; # = NIL ?
  3785.           #ifdef LOGICAL_PATHNAMES
  3786.           elif (logical)
  3787.             { if (logpathnamep(device)) # Pathname -> dessen Device
  3788.                 { STACK_4 = NIL; goto device_ok; }
  3789.             }
  3790.           #endif
  3791.           #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  3792.           elif (eq(device,S(Kwild))) goto device_ok; # = :WILD ?
  3793.           elif (simple_string_p(device)) # Simple-String ?
  3794.             { if (TheSstring(device)->length == 1) # der LΣnge 1 ?
  3795.                 { var reg2 uintB ch = TheSstring(device)->data[0];
  3796.                   if ((ch >= 'A') && (ch <= 'Z')) # mit Buchstaben >='A' und <='Z' ?
  3797.                     goto device_ok;
  3798.             }   }
  3799.           #endif
  3800.           #ifdef PATHNAME_AMIGAOS
  3801.           elif (simple_string_p(device)) # Simple-String ?
  3802.             { var reg1 uintB* ptr = &TheSstring(device)->data[0];
  3803.               var reg2 uintL count;
  3804.               dotimesL(count,TheSstring(device)->length,
  3805.                 { if (!legal_namechar(*ptr++)) goto device_not_ok; }
  3806.                 );
  3807.               goto device_ok;
  3808.               device_not_ok: ;
  3809.             }
  3810.           #endif
  3811.           #ifdef PATHNAME_RISCOS
  3812.           elif (simple_string_p(device)) # Simple-String ?
  3813.             { var reg2 uintB* ptr = &TheSstring(device)->data[0];
  3814.               var reg3 uintL count;
  3815.               dotimesL(count,TheSstring(device)->length,
  3816.                 { var reg2 uintB ch = *ptr++;
  3817.                   if (!(legal_namechar(ch) && !(ch=='*') && !singlewild_char_p(ch)))
  3818.                     goto device_not_ok;
  3819.                 });
  3820.               goto device_ok;
  3821.               device_not_ok: ;
  3822.             }
  3823.           #endif
  3824.           elif (xpathnamep(device)) # Pathname -> dessen Device
  3825.             {
  3826.               #ifdef LOGICAL_PATHNAMES
  3827.               device = coerce_pathname(device);
  3828.               #endif
  3829.               STACK_4 = ThePathname(device)->pathname_device; goto device_ok;
  3830.             }
  3831.           # Keiner der gewⁿnschten FΣlle -> Fehler:
  3832.           pushSTACK(STACK_4); pushSTACK(S(Kdevice)); goto fehler_arg;
  3833.           device_ok: ;
  3834.     }   }
  3835.     #else
  3836.     { var reg1 object device = STACK_4;
  3837.       if (!eq(device,unbound)) # angegeben ?
  3838.         if (!(nullp(device) || xpathnamep(device))) # NIL oder Pathname -> OK
  3839.           # Keiner der gewⁿnschten FΣlle -> Fehler:
  3840.           { pushSTACK(STACK_4); pushSTACK(S(Kdevice)); goto fehler_arg; }
  3841.     }
  3842.     #endif
  3843.     # 3. directory ⁿberprⁿfen:
  3844.     { var reg1 object directory = STACK_3;
  3845.       if (eq(directory,unbound) || nullp(directory)) # nicht angegeben oder =NIL ?
  3846.         { STACK_3 = O(directory_default); # Default ist ([NIL] :RELATIVE)
  3847.           goto directory_ok;
  3848.         }
  3849.       elif (consp(directory)) # ein Cons?
  3850.         { if (convert) { STACK_3 = directory = subst_common_case(directory); }
  3851.           #ifdef LOGICAL_PATHNAMES
  3852.           if (!logical)
  3853.           #endif
  3854.             {
  3855.               #if HAS_SERNR
  3856.               # Der CAR entweder NIL oder ein Fixnum >=0 ?
  3857.               if (!(nullp(Car(directory)) || mposfixnump(Car(directory))))
  3858.                 goto directory_bad;
  3859.               directory = Cdr(directory); # subdir-Liste
  3860.               #endif
  3861.             }
  3862.           # Der CAR entweder :RELATIVE oder :ABSOLUTE ?
  3863.           if (!consp(directory)) goto directory_bad;
  3864.           { var reg1 object startpoint = Car(directory);
  3865.             if (!(eq(startpoint,S(Krelative)) || eq(startpoint,S(Kabsolute))))
  3866.               goto directory_bad;
  3867.             #ifdef PATHNAME_RISCOS
  3868.             if (!logical && eq(startpoint,S(Kabsolute)))
  3869.               { directory = Cdr(directory);
  3870.                 startpoint = Car(directory);
  3871.                 if (!(eq(startpoint,S(Kroot))
  3872.                       || eq(startpoint,S(Khome))
  3873.                       || eq(startpoint,S(Kcurrent))
  3874.                       || eq(startpoint,S(Klibrary))
  3875.                       || eq(startpoint,S(Kprevious))
  3876.                    ) )
  3877.                   goto directory_bad;
  3878.               }
  3879.             #endif
  3880.           }
  3881.           directory = Cdr(directory);
  3882.           # Subdir-Liste ⁿberprⁿfen:
  3883.           while (consp(directory))
  3884.             { # nΣchstes subdir ⁿberprⁿfen:
  3885.               var reg1 object subdir = Car(directory);
  3886.               #ifdef LOGICAL_PATHNAMES
  3887.               if (logical)
  3888.                 { if (!(eq(subdir,S(Kwild_inferiors)) || legal_logical_word(subdir)))
  3889.                     goto directory_bad;
  3890.                 }
  3891.                 else
  3892.               #endif
  3893.                 {
  3894.                   #ifdef PATHNAME_EXT83
  3895.                   if (consp(subdir))
  3896.                     { # subdir ist ein Cons
  3897.                       if (!(legal_name(Car(subdir)) && legal_type(Cdr(subdir))))
  3898.                         goto directory_bad;
  3899.                     }
  3900.                     else
  3901.                     { # subdir ist ein Atom
  3902.                       if (!(eq(subdir,S(Kcurrent)) # = :CURRENT ?
  3903.                             || eq(subdir,S(Kparent)) # = :PARENT ?
  3904.                             || eq(subdir,S(Kwild_inferiors)) # = :WILD-INFERIORS ?
  3905.                          ) )
  3906.                         goto directory_bad;
  3907.                     }
  3908.                   #endif
  3909.                   #ifdef PATHNAME_NOEXT
  3910.                   #ifdef PATHNAME_AMIGAOS
  3911.                   if (!(eq(subdir,S(Kwild_inferiors)) || eq(subdir,S(Kparent))
  3912.                         || legal_name(subdir)
  3913.                      ) )
  3914.                     goto directory_bad;
  3915.                   #endif
  3916.                   #if defined(PATHNAME_UNIX) || defined(PATHNAME_OS2)
  3917.                   if (!(eq(subdir,S(Kwild_inferiors)) || legal_name(subdir)))
  3918.                     goto directory_bad;
  3919.                   #endif
  3920.                   #endif
  3921.                   #ifdef PATHNAME_RISCOS
  3922.                   if (!(eq(subdir,S(Kparent)) || legal_name(subdir)))
  3923.                     goto directory_bad;
  3924.                   #endif
  3925.                 }
  3926.               directory = Cdr(directory);
  3927.             }
  3928.           goto directory_ok;
  3929.         }
  3930.       #ifdef LOGICAL_PATHNAMES
  3931.       elif (logical)
  3932.         { if (logpathnamep(directory)) # Pathname -> dessen Directory
  3933.             { STACK_3 = TheLogpathname(directory)->pathname_directory; goto directory_ok; }
  3934.         }
  3935.       #endif
  3936.       elif (xpathnamep(directory)) # Pathname -> dessen Directory
  3937.         {
  3938.           #ifdef LOGICAL_PATHNAMES
  3939.           directory = coerce_pathname(directory);
  3940.           #endif
  3941.           STACK_3 = ThePathname(directory)->pathname_directory; goto directory_ok;
  3942.         }
  3943.       # Keiner der gewⁿnschten FΣlle -> Fehler:
  3944.       directory_bad:
  3945.       pushSTACK(STACK_3); pushSTACK(S(Kdirectory)); goto fehler_arg;
  3946.       directory_ok: ;
  3947.       #ifdef PATHNAME_AMIGAOS
  3948.       # Bei device /= NIL mu▀ directory mit :ABSOLUTE anfangen:
  3949.       if (!nullp(STACK_4) && !eq(Car(STACK_3),S(Kabsolute))) goto directory_bad;
  3950.       #endif
  3951.     }
  3952.     # 4. name ⁿberprⁿfen:
  3953.     { var reg1 object name = STACK_2;
  3954.       if (convert) { STACK_2 = name = common_case(name); }
  3955.       if (eq(name,unbound))
  3956.         { STACK_2 = NIL; } # nicht angegeben -> verwende NIL
  3957.       elif (nullp(name)) {} # NIL ist OK
  3958.       #ifdef LOGICAL_PATHNAMES
  3959.       elif (logical)
  3960.         { if (legal_logical_word(name)) {} # OK
  3961.           elif (logpathnamep(name)) # Pathname -> dessen Name
  3962.             { STACK_2 = TheLogpathname(name)->pathname_name; }
  3963.           else # Keiner der gewⁿnschten FΣlle -> Fehler:
  3964.             { pushSTACK(STACK_2); pushSTACK(S(Kname)); goto fehler_arg; }
  3965.         }
  3966.       #endif
  3967.       #if defined(PATHNAME_NOEXT) || defined(PATHNAME_RISCOS)
  3968.       elif (eq(name,S(Kwild))) { STACK_2 = O(wild_string); } # aus :WILD mache "*"
  3969.       #endif
  3970.       elif (equal(name,O(leer_string))) # name = "" ?
  3971.         { STACK_2 = NIL; } # ja -> verwende NIL
  3972.       elif (legal_name(name)) {} # zulΣssiger Name ist OK
  3973.       elif (xpathnamep(name)) # Pathname -> dessen Name
  3974.         {
  3975.           #ifdef LOGICAL_PATHNAMES
  3976.           name = coerce_pathname(name);
  3977.           #endif
  3978.           STACK_2 = ThePathname(name)->pathname_name;
  3979.         }
  3980.       else # Keiner der gewⁿnschten FΣlle -> Fehler:
  3981.         { pushSTACK(STACK_2); pushSTACK(S(Kname)); goto fehler_arg; }
  3982.     }
  3983.     # 5. type ⁿberprⁿfen:
  3984.     { var reg1 object type = STACK_1;
  3985.       if (convert) { STACK_1 = type = common_case(type); }
  3986.       if (eq(type,unbound))
  3987.         { STACK_1 = NIL; } # nicht angegeben -> verwende NIL
  3988.       elif (nullp(type)) {} # NIL ist OK
  3989.       #ifdef LOGICAL_PATHNAMES
  3990.       elif (logical)
  3991.         { if (legal_logical_word(type)) {} # OK
  3992.           elif (logpathnamep(type)) # Pathname -> dessen Typ
  3993.             { STACK_1 = TheLogpathname(type)->pathname_type; }
  3994.           else # Keiner der gewⁿnschten FΣlle -> Fehler:
  3995.             { pushSTACK(STACK_1); pushSTACK(S(Ktype)); goto fehler_arg; }
  3996.         }
  3997.       #endif
  3998.       #if defined(PATHNAME_NOEXT) || defined(PATHNAME_RISCOS)
  3999.       elif (eq(type,S(Kwild))) { STACK_1 = O(wild_string); } # aus :WILD mache "*"
  4000.       #endif
  4001.       elif (legal_type(type)) {} # zulΣssiger Typ ist OK
  4002.       elif (xpathnamep(type)) # Pathname -> dessen Typ
  4003.         {
  4004.           #ifdef LOGICAL_PATHNAMES
  4005.           type = coerce_pathname(type);
  4006.           #endif
  4007.           STACK_1 = ThePathname(type)->pathname_type;
  4008.         }
  4009.       else # Keiner der gewⁿnschten FΣlle -> Fehler:
  4010.         { pushSTACK(STACK_1); pushSTACK(S(Ktype)); goto fehler_arg; }
  4011.     }
  4012.     # 6. version ⁿberprⁿfen:
  4013.     #if HAS_VERSION || defined(LOGICAL_PATHNAMES)
  4014.     STACK_0 = test_optional_version(NIL); # Default ist NIL
  4015.     #else
  4016.     test_optional_version(NIL);
  4017.     #endif
  4018.     # 7. Pathname bauen:
  4019.     {var reg1 object pathname;
  4020.      #ifdef LOGICAL_PATHNAMES
  4021.      if (logical)
  4022.        { pathname = allocate_logpathname(); # neuer Logical Pathname
  4023.          TheLogpathname(pathname)->pathname_version   = popSTACK();
  4024.          TheLogpathname(pathname)->pathname_type      = popSTACK();
  4025.          TheLogpathname(pathname)->pathname_name      = popSTACK();
  4026.          TheLogpathname(pathname)->pathname_directory = popSTACK();
  4027.          skipSTACK(1);
  4028.          TheLogpathname(pathname)->pathname_host      = popSTACK();
  4029.        }
  4030.        else
  4031.      #endif
  4032.        { pathname = allocate_pathname(); # neuer Pathname
  4033.          #if HAS_VERSION
  4034.          ThePathname(pathname)->pathname_version   = popSTACK();
  4035.          #else
  4036.          skipSTACK(1);
  4037.          #endif
  4038.          ThePathname(pathname)->pathname_type      = popSTACK();
  4039.          ThePathname(pathname)->pathname_name      = popSTACK();
  4040.          ThePathname(pathname)->pathname_directory = popSTACK();
  4041.          #if HAS_DEVICE
  4042.          ThePathname(pathname)->pathname_device    = popSTACK();
  4043.          #else
  4044.          skipSTACK(1);
  4045.          #endif
  4046.          #if HAS_HOST
  4047.          ThePathname(pathname)->pathname_host      = popSTACK();
  4048.          #else
  4049.          skipSTACK(1);
  4050.          #endif
  4051.        }
  4052.     skipSTACK(1); # case vergessen
  4053.     # 8. evtl. Defaults hineinmergen:
  4054.      {var reg2 object defaults = popSTACK();
  4055.       if (eq(defaults,unbound))
  4056.         # keine Defaults angegeben -> pathname als Wert
  4057.         { value1 = pathname; }
  4058.         else
  4059.         # (MERGE-PATHNAMES pathname defaults [nil]) aufrufen:
  4060.         { pushSTACK(pathname); pushSTACK(defaults); pushSTACK(NIL);
  4061.           funcall(L(merge_pathnames),3);
  4062.         }
  4063.       mv_count=1;
  4064.       return;
  4065.     }}
  4066.     # Fehlermeldung:
  4067.     fehler_arg:
  4068.     pushSTACK(TheSubr(subr_self)->name);
  4069.     fehler(error,
  4070.            DEUTSCH ? "~: UnzulΣssiges ~-Argument ~" :
  4071.            ENGLISH ? "~: illegal ~ argument ~" :
  4072.            FRANCAIS ? "~ : Argument incorrect pour ~ : ~" :
  4073.            ""
  4074.           );
  4075.   }
  4076.  
  4077. #ifdef LOGICAL_PATHNAMES
  4078.  
  4079. LISPFUN(make_logical_pathname,0,0,norest,key,8,\
  4080.         (kw(defaults),kw(case),kw(host),kw(device),kw(directory),kw(name),kw(type),kw(version)) )
  4081. # (MAKE-LOGICAL-PATHNAME [:host] [:device] [:directory] [:name] [:type] [:version]
  4082. #                        [:defaults] [:case]),
  4083. # wie MAKE-PATHNAME, nur da▀ ein Logical Pathname gebildet wird.
  4084.   { # Ein logischer Pathname als :HOST-Argument zu MAKE-PATHNAME
  4085.     # erzwingt einen logischen Pathname als Ergebnis.
  4086.     var reg1 object obj = allocate_logpathname();
  4087.     TheLogpathname(obj)->pathname_host = (!eq(STACK_5,unbound) ? STACK_5 : NIL);
  4088.     STACK_5 = obj;
  4089.     # weiter bei MAKE-PATHNAME.
  4090.     C_make_pathname();
  4091.   }
  4092.  
  4093. #endif
  4094.  
  4095. #ifdef USER_HOMEDIR
  4096. LISPFUN(user_homedir_pathname,0,1,norest,nokey,0,NIL)
  4097. # (USER-HOMEDIR-PATHNAME [host]), CLTL S. 418
  4098.   {
  4099.     #if HAS_HOST
  4100.     STACK_0 = test_optional_host(STACK_0,FALSE); # Host ⁿberprⁿfen
  4101.     #ifdef PATHNAME_RISCOS
  4102.     {var reg1 object pathname = allocate_pathname(); # neuer Pathname
  4103.      ThePathname(pathname)->pathname_host      = popSTACK();
  4104.      #if HAS_DEVICE
  4105.      ThePathname(pathname)->pathname_device    = NIL;
  4106.      #endif
  4107.      ThePathname(pathname)->pathname_directory = O(directory_homedir);
  4108.      ThePathname(pathname)->pathname_name      = NIL;
  4109.      ThePathname(pathname)->pathname_type      = NIL;
  4110.      #if HAS_VERSION
  4111.      ThePathname(pathname)->pathname_version   = NIL;
  4112.      #endif
  4113.      value1 = pathname;
  4114.     }
  4115.     #else
  4116.     ??
  4117.     #endif
  4118.     #else
  4119.     test_optional_host(popSTACK()); # Host ⁿberprⁿfen und ignorieren
  4120.     value1 = O(user_homedir); # User-Homedir-Pathname
  4121.     #endif
  4122.     mv_count=1; # als Wert
  4123.   }
  4124. #endif
  4125.  
  4126. # UP: Kopiert einen Pathname.
  4127. # copy_pathname(pathname)
  4128. # > pathname: nicht-Logical Pathname
  4129. # < ergebnis: Kopie des Pathname, mit denselben Komponenten
  4130. # kann GC ausl÷sen
  4131.   local object copy_pathname (object pathname);
  4132.   local object copy_pathname(pathname)
  4133.     var reg2 object pathname;
  4134.     { pushSTACK(pathname);
  4135.      {var reg1 object new = allocate_pathname();
  4136.       pathname = popSTACK();
  4137.       #if HAS_HOST
  4138.       ThePathname(new)->pathname_host      = ThePathname(pathname)->pathname_host     ;
  4139.       #endif
  4140.       #if HAS_DEVICE
  4141.       ThePathname(new)->pathname_device    = ThePathname(pathname)->pathname_device   ;
  4142.       #endif
  4143.       ThePathname(new)->pathname_directory = ThePathname(pathname)->pathname_directory;
  4144.       ThePathname(new)->pathname_name      = ThePathname(pathname)->pathname_name     ;
  4145.       ThePathname(new)->pathname_type      = ThePathname(pathname)->pathname_type     ;
  4146.       #if HAS_VERSION
  4147.       ThePathname(new)->pathname_version   = ThePathname(pathname)->pathname_version  ;
  4148.       #endif
  4149.       return new;
  4150.     }}
  4151.  
  4152. # Wildcards
  4153. # =========
  4154.  
  4155. #if defined(PATHNAME_NOEXT) || defined(PATHNAME_RISCOS)
  4156. # UP: Testet, ob ein Simple-String Wildcards enthΣlt.
  4157. # has_wildcards(string)
  4158. # > string: Simple-String
  4159. # < ergebnis: TRUE wenn string Wildcard-Zeichen enthΣlt
  4160.   local boolean has_wildcards (object string);
  4161.   local boolean has_wildcards(string)
  4162.     var reg4 object string;
  4163.     { var reg3 uintL len = TheSstring(string)->length;
  4164.       var reg2 uintB* charptr = &TheSstring(string)->data[0];
  4165.       dotimesL(len,len,
  4166.         { var reg1 uintB ch = *charptr++;
  4167.           if ((ch=='*') # Wildcard fⁿr beliebig viele Zeichen
  4168.               || singlewild_char_p(ch) # Wildcard fⁿr genau ein Zeichen
  4169.              )
  4170.             { return TRUE; }
  4171.         });
  4172.       return FALSE;
  4173.     }
  4174. #endif
  4175.  
  4176. #ifdef LOGICAL_PATHNAMES
  4177. # UP: Testet, ob ein Simple-String Wildcards enthΣlt.
  4178. # has_word_wildcards(string)
  4179. # > string: Simple-String
  4180. # < ergebnis: TRUE wenn string Wildcard-Zeichen enthΣlt
  4181.   local boolean has_word_wildcards (object string);
  4182.   local boolean has_word_wildcards(string)
  4183.     var reg3 object string;
  4184.     { var reg2 uintL len = TheSstring(string)->length;
  4185.       var reg1 uintB* charptr = &TheSstring(string)->data[0];
  4186.       dotimesL(len,len, { if (*charptr++ == '*') { return TRUE; } } );
  4187.       return FALSE;
  4188.     }
  4189. #endif
  4190.  
  4191. # UP: Testet, ob die Host-Komponente eines Pathname Wildcards enthΣlt.
  4192. # has_host_wildcards(pathname)
  4193. # > pathname: Pathname
  4194. # < ergebnis: TRUE wenn (PATHNAME-HOST pathname) Wildcards enthΣlt.
  4195.   local boolean has_host_wildcards (object pathname);
  4196.   # Host kann keine Wildcards enthalten.
  4197.   #define has_host_wildcards(pathname)  (pathname, FALSE)
  4198.  
  4199. # UP: Testet, ob die Device-Komponente eines Pathname Wildcards enthΣlt.
  4200. # has_device_wildcards(pathname)
  4201. # > pathname: Pathname
  4202. # < ergebnis: TRUE wenn (PATHNAME-DEVICE pathname) Wildcards enthΣlt.
  4203.   local boolean has_device_wildcards (object pathname);
  4204.   local boolean has_device_wildcards(pathname)
  4205.     var reg1 object pathname;
  4206.     {
  4207.       #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  4208.       #ifdef LOGICAL_PATHNAMES
  4209.       if (logpathnamep(pathname))
  4210.         return FALSE;
  4211.       #endif
  4212.       # Device ⁿberprⁿfen: = :WILD ?
  4213.       return eq(ThePathname(pathname)->pathname_device,S(Kwild));
  4214.       #else
  4215.       return FALSE;
  4216.       #endif
  4217.     }
  4218.  
  4219. # UP: Testet, ob die Directory-Komponente eines Pathname Wildcards enthΣlt.
  4220. # has_directory_wildcards(pathname)
  4221. # > pathname: Pathname
  4222. # < ergebnis: TRUE wenn (PATHNAME-DIRECTORY pathname) Wildcards enthΣlt.
  4223.   local boolean has_directory_wildcards (object pathname);
  4224.   local boolean has_directory_wildcards(pathname)
  4225.     var reg3 object pathname;
  4226.     { # Directory ⁿberprⁿfen:
  4227.       #ifdef LOGICAL_PATHNAMES
  4228.       if (logpathnamep(pathname))
  4229.         { var reg1 object directory = TheLogpathname(pathname)->pathname_directory;
  4230.           while (consp(directory = Cdr(directory)))
  4231.             { var reg2 object subdir = Car(directory);
  4232.               if (simple_string_p(subdir))
  4233.                 { if (has_word_wildcards(subdir)) return TRUE; }
  4234.                 else
  4235.                 { if (eq(subdir,S(Kwild)) || eq(subdir,S(Kwild_inferiors)))
  4236.                     return TRUE;
  4237.             }   }
  4238.           return FALSE;
  4239.         }
  4240.       #endif
  4241.      {var reg1 object directory = ThePathname(pathname)->pathname_directory;
  4242.       #if HAS_SERNR
  4243.       directory = Cdr(directory); # Seriennummer ⁿbergehen
  4244.       #endif
  4245.       while (consp(directory = Cdr(directory)))
  4246.         { var reg2 object subdir = Car(directory);
  4247.           #ifdef PATHNAME_EXT83
  4248.           if (consp(subdir))
  4249.             { # subdir ist ein Cons. name oder type = :WILD ?
  4250.               if (eq(Car(subdir),S(Kwild)) || eq(Cdr(subdir),S(Kwild)))
  4251.                 return TRUE;
  4252.             }
  4253.             else
  4254.             { # subdir ist ein Atom. = :WILD-INFERIORS ?
  4255.               if (eq(subdir,S(Kwild_inferiors)))
  4256.                 return TRUE;
  4257.             }
  4258.           #endif
  4259.           #ifdef PATHNAME_NOEXT
  4260.           if (simple_string_p(subdir))
  4261.             { if (has_wildcards(subdir)) return TRUE; }
  4262.             else
  4263.             { if (eq(subdir,S(Kwild_inferiors))) return TRUE; }
  4264.           #endif
  4265.           #ifdef PATHNAME_RISCOS
  4266.           if (simple_string_p(subdir))
  4267.             { if (has_wildcards(subdir)) return TRUE; }
  4268.           #endif
  4269.         }
  4270.       return FALSE;
  4271.     }}
  4272.  
  4273. # UP: Testet, ob die Name-Komponente eines Pathname Wildcards enthΣlt.
  4274. # has_name_wildcards(pathname)
  4275. # > pathname: Pathname
  4276. # < ergebnis: TRUE wenn (PATHNAME-NAME pathname) Wildcards enthΣlt.
  4277.   local boolean has_name_wildcards (object pathname);
  4278.   local boolean has_name_wildcards(pathname)
  4279.     var reg2 object pathname;
  4280.     { # Name ⁿberprⁿfen:
  4281.       #ifdef LOGICAL_PATHNAMES
  4282.       if (logpathnamep(pathname))
  4283.         { var reg1 object name = TheLogpathname(pathname)->pathname_name;
  4284.           if (simple_string_p(name))
  4285.             { if (has_word_wildcards(name)) return TRUE; }
  4286.             else
  4287.             { if (eq(name,S(Kwild))) return TRUE; }
  4288.           return FALSE;
  4289.         }
  4290.       #endif
  4291.       #ifdef PATHNAME_EXT83
  4292.       if (eq(ThePathname(pathname)->pathname_name,S(Kwild))) # Name = :WILD ?
  4293.         return TRUE;
  4294.       #endif
  4295.       #if defined(PATHNAME_NOEXT) || defined(PATHNAME_RISCOS)
  4296.       { var reg1 object name = ThePathname(pathname)->pathname_name;
  4297.         if (simple_string_p(name))
  4298.           { if (has_wildcards(name)) return TRUE; }
  4299.       }
  4300.       #endif
  4301.       return FALSE;
  4302.     }
  4303.  
  4304. # UP: Testet, ob die Type-Komponente eines Pathname Wildcards enthΣlt.
  4305. # has_type_wildcards(pathname)
  4306. # > pathname: Pathname
  4307. # < ergebnis: TRUE wenn (PATHNAME-TYPE pathname) Wildcards enthΣlt.
  4308.   local boolean has_type_wildcards (object pathname);
  4309.   local boolean has_type_wildcards(pathname)
  4310.     var reg2 object pathname;
  4311.     { # Typ ⁿberprⁿfen:
  4312.       #ifdef LOGICAL_PATHNAMES
  4313.       if (logpathnamep(pathname))
  4314.         { var reg1 object type = TheLogpathname(pathname)->pathname_type;
  4315.           if (simple_string_p(type))
  4316.             { if (has_word_wildcards(type)) return TRUE; }
  4317.             else
  4318.             { if (eq(type,S(Kwild))) return TRUE; }
  4319.           return FALSE;
  4320.         }
  4321.       #endif
  4322.       #ifdef PATHNAME_EXT83
  4323.       if (eq(ThePathname(pathname)->pathname_type,S(Kwild))) # Typ = :WILD ?
  4324.         return TRUE;
  4325.       #endif
  4326.       #if defined(PATHNAME_NOEXT) || defined(PATHNAME_RISCOS)
  4327.       { var reg1 object type = ThePathname(pathname)->pathname_type;
  4328.         if (simple_string_p(type))
  4329.           { if (has_wildcards(type)) return TRUE; }
  4330.       }
  4331.       #endif
  4332.       return FALSE;
  4333.     }
  4334.  
  4335. # UP: Testet, ob die Version-Komponente eines Pathname Wildcards enthΣlt.
  4336. # has_version_wildcards(pathname)
  4337. # > pathname: Pathname
  4338. # < ergebnis: TRUE wenn (PATHNAME-VERSION pathname) Wildcards enthΣlt.
  4339.   local boolean has_version_wildcards (object pathname);
  4340.   local boolean has_version_wildcards(pathname)
  4341.     var reg2 object pathname;
  4342.     { # Version ⁿberprⁿfen:
  4343.       #ifdef LOGICAL_PATHNAMES
  4344.       if (logpathnamep(pathname))
  4345.         { if (eq(TheLogpathname(pathname)->pathname_version,S(Kwild)))
  4346.             return TRUE;
  4347.           return FALSE;
  4348.         }
  4349.       #endif
  4350.       return FALSE;
  4351.     }
  4352.  
  4353. # UP: Testet, ob irgendeine Komponente eines Pathname Wildcards enthΣlt.
  4354. # has_some_wildcards(pathname)
  4355. # > pathname: Pathname
  4356. # < ergebnis: TRUE wenn pathname Wildcards enthΣlt.
  4357.   local boolean has_some_wildcards (object pathname);
  4358.   local boolean has_some_wildcards(pathname)
  4359.     var reg1 object pathname;
  4360.     { if (has_host_wildcards(pathname)) return TRUE;
  4361.       if (has_device_wildcards(pathname)) return TRUE;
  4362.       if (has_directory_wildcards(pathname)) return TRUE;
  4363.       if (has_name_wildcards(pathname)) return TRUE;
  4364.       if (has_type_wildcards(pathname)) return TRUE;
  4365.       if (has_version_wildcards(pathname)) return TRUE;
  4366.       return FALSE;
  4367.     }
  4368.  
  4369. # UP: ▄berprⁿft, ob ein Pathname keine Wildcards enthΣlt.
  4370. # check_no_wildcards(pathname);
  4371. # > pathname: Pathname
  4372.   local void check_no_wildcards (object pathname);
  4373.   local void check_no_wildcards(pathname)
  4374.     var reg2 object pathname;
  4375.     { if (!has_some_wildcards(pathname))
  4376.         # Keine Wildcards gefunden.
  4377.         return;
  4378.       # Fehlermeldung, wenn der Pathname Wildcards enthΣlt:
  4379.       pushSTACK(pathname); # Wert fⁿr Slot PATHNAME von FILE-ERROR
  4380.       pushSTACK(pathname);
  4381.       fehler(file_error,
  4382.              DEUTSCH ? "Hier sind keine Wildcards (Dateiquantoren) erlaubt: ~" :
  4383.              ENGLISH ? "wildcards are not allowed here: ~" :
  4384.              FRANCAIS ? "Les caractΦres joker ne sont pas permis ici : ~" :
  4385.              ""
  4386.             );
  4387.     }
  4388.  
  4389. LISPFUN(wild_pathname_p,1,1,norest,nokey,0,NIL)
  4390. # (WILD-PATHNAME-P pathname [field-key]), CLtL2 S. 623
  4391.   { var reg3 object pathname = coerce_xpathname(STACK_1);
  4392.     var reg1 object key = STACK_0;
  4393.     var reg2 boolean erg;
  4394.     if (eq(key,unbound) || nullp(key)) { erg = has_some_wildcards(pathname); }
  4395.     elif (eq(key,S(Khost))) { erg = has_host_wildcards(pathname); }
  4396.     elif (eq(key,S(Kdevice))) { erg = has_device_wildcards(pathname); }
  4397.     elif (eq(key,S(Kdirectory))) { erg = has_directory_wildcards(pathname); }
  4398.     elif (eq(key,S(Kname))) { erg = has_name_wildcards(pathname); }
  4399.     elif (eq(key,S(Ktype))) { erg = has_type_wildcards(pathname); }
  4400.     elif (eq(key,S(Kversion))) { erg = has_version_wildcards(pathname); }
  4401.     else
  4402.       { pushSTACK(key); # Wert fⁿr Slot DATUM von TYPE-ERROR
  4403.         pushSTACK(O(type_pathname_field_key)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  4404.         pushSTACK(NIL);
  4405.         pushSTACK(S(Kversion));
  4406.         pushSTACK(S(Ktype));
  4407.         pushSTACK(S(Kname));
  4408.         pushSTACK(S(Kdirectory));
  4409.         pushSTACK(S(Kdevice));
  4410.         pushSTACK(S(Khost));
  4411.         pushSTACK(key);
  4412.         pushSTACK(TheSubr(subr_self)->name);
  4413.         fehler(type_error,
  4414.                DEUTSCH ? "~: Argument ~ sollte ~, ~, ~, ~, ~, ~ oder ~ sein." :
  4415.                ENGLISH ? "~: argument ~ should be ~, ~, ~, ~, ~, ~ or ~" :
  4416.                FRANCAIS ? "~ : L'argument ~ devrait Ωtre ~, ~, ~, ~, ~, ~ ou ~ ." :
  4417.                ""
  4418.               );
  4419.       }
  4420.     value1 = (erg ? T : NIL); mv_count=1; # boolescher Wert
  4421.     skipSTACK(2);
  4422.   }
  4423.  
  4424. #if defined(PATHNAME_NOEXT) || defined(LOGICAL_PATHNAMES)
  4425.  
  4426.   # UP: Matcht einen Wildcard-String ("Muster") mit einem "Beispiel".
  4427.   # > muster: Simple-String, mit Platzhaltern
  4428.   #           '?' fⁿr genau 1 Zeichen
  4429.   #           '*' fⁿr beliebig viele Zeichen
  4430.   # > beispiel: Simple-String, der damit zu matchen ist
  4431.   local boolean wildcard_match (object muster, object beispiel);
  4432.   # rekursive Implementation wegen Backtracking:
  4433.   local boolean wildcard_match_ab (uintL m_count, uintB* m_ptr, uintL b_count, uintB* b_ptr);
  4434.   local boolean wildcard_match(muster,beispiel)
  4435.     var reg2 object muster;
  4436.     var reg1 object beispiel;
  4437.     { return wildcard_match_ab(
  4438.                                /* m_count = */ TheSstring(muster)->length,
  4439.                                /* m_ptr   = */ &TheSstring(muster)->data[0],
  4440.                                /* b_count = */ TheSstring(beispiel)->length,
  4441.                                /* b_ptr   = */ &TheSstring(beispiel)->data[0]
  4442.                               );
  4443.     }
  4444.   local boolean wildcard_match_ab(m_count,m_ptr,b_count,b_ptr)
  4445.     var reg5 uintL m_count;
  4446.     var reg2 uintB* m_ptr;
  4447.     var reg4 uintL b_count;
  4448.     var reg1 uintB* b_ptr;
  4449.     { var reg3 uintB c;
  4450.       loop
  4451.         { if (m_count==0)
  4452.             { return (b_count==0 ? TRUE : FALSE); } # "" matcht nur ""
  4453.           m_count--;
  4454.           c = *m_ptr++; # nΣchstes Match-Zeichen
  4455.           if (c=='?') # Wildcard '?'
  4456.             { if (b_count==0) return FALSE; # mindestens ein Zeichen mu▀ noch kommen
  4457.               b_count--; b_ptr++; # es wird ignoriert
  4458.             }
  4459.           elif (c=='*') break; # Wildcard '*' spΣter
  4460.           else # alles andere mu▀ genau matchen:
  4461.             { if (b_count==0) return FALSE;
  4462.               b_count--; if (!equal_pathchar(*b_ptr++,c)) return FALSE;
  4463.             }
  4464.         }
  4465.       # Wildcard '*': Suche nΣchstes non-Wildcard-Zeichen und zΣhle die '?'
  4466.       # mit (denn eine Folge '*??*???***?' matcht alles, was mindestens so
  4467.       # lang ist, wie die Folge Fragezeichen enthΣlt). Man kann die '?' auch
  4468.       # gleich verwerten, denn '*??*???***?' ist zu '??????*' Σquivalent.
  4469.       loop
  4470.         { if (m_count==0) return TRUE; # Wildcard am Ende matcht den Rest.
  4471.           m_count--;
  4472.           c = *m_ptr++; # nΣchstes Match-Zeichen
  4473.           if (c=='?') # Fragezeichen: nach vorne ziehen, sofort abarbeiten
  4474.             { if (b_count==0) return FALSE;
  4475.               b_count--; b_ptr++;
  4476.             }
  4477.           elif (!(c=='*')) break;
  4478.         }
  4479.       # c = nΣchstes non-Wildcard-Zeichen. Suche es.
  4480.       loop
  4481.         { if (b_count==0) return FALSE; # c nicht gefunden
  4482.           b_count--;
  4483.           if (equal_pathchar(*b_ptr++,c))
  4484.             { if (wildcard_match_ab(m_count,m_ptr,b_count,b_ptr))
  4485.                 return TRUE;
  4486.         }   }
  4487.     }
  4488.  
  4489. #endif
  4490.  
  4491. # UPs: Matcht jeweils eine Pathname-Komponente ("Beispiel") und
  4492. # eine Pathname-Komponente ("Muster").
  4493.   local boolean host_match (object muster, object beispiel, boolean logical);
  4494.   local boolean device_match (object muster, object beispiel, boolean logical);
  4495.   local boolean directory_match (object muster, object beispiel, boolean logical);
  4496.   local boolean nametype_match (object muster, object beispiel, boolean logical);
  4497.   local boolean version_match (object muster, object beispiel, boolean logical);
  4498.   local boolean host_match(muster,beispiel,logical)
  4499.     var reg2 object muster;
  4500.     var reg1 object beispiel;
  4501.     var reg3 boolean logical;
  4502.     {
  4503.       #ifdef LOGICAL_PATHNAMES
  4504.       if (logical)
  4505.         { return equal(muster,beispiel); }
  4506.       #endif
  4507.       #if HAS_HOST
  4508.       return equal(muster,beispiel);
  4509.       #else
  4510.       return TRUE;
  4511.       #endif
  4512.     }
  4513.   local boolean device_match(muster,beispiel,logical)
  4514.     var reg2 object muster;
  4515.     var reg1 object beispiel;
  4516.     var reg3 boolean logical;
  4517.     {
  4518.       #if HAS_DEVICE
  4519.       #ifdef LOGICAL_PATHNAMES
  4520.       if (logical)
  4521.         { return TRUE; }
  4522.       #endif
  4523.       #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  4524.       if (eq(muster,S(Kwild))) return TRUE;
  4525.       if (eq(beispiel,S(Kwild))) return FALSE;
  4526.       #endif
  4527.       #if defined(PATHNAME_AMIGAOS) || defined(PATHNAME_OS2)
  4528.       return equalp(muster,beispiel);
  4529.       #else
  4530.       return equal(muster,beispiel);
  4531.       #endif
  4532.       #else
  4533.       return TRUE;
  4534.       #endif
  4535.     }
  4536.   local boolean nametype_match(muster,beispiel,logical)
  4537.     var reg2 object muster;
  4538.     var reg1 object beispiel;
  4539.     var reg3 boolean logical;
  4540.     {
  4541.       #ifdef LOGICAL_PATHNAMES
  4542.       if (logical)
  4543.         { if (eq(muster,S(Kwild))) return TRUE;
  4544.           if (eq(beispiel,S(Kwild))) return FALSE;
  4545.           if (nullp(muster))
  4546.             { if (nullp(beispiel)) return TRUE; else return FALSE; }
  4547.           if (nullp(beispiel))
  4548.             { return FALSE; }
  4549.           return wildcard_match(muster,beispiel);
  4550.         }
  4551.       #endif
  4552.       #ifdef PATHNAME_EXT83
  4553.       if (eq(muster,S(Kwild))) return TRUE;
  4554.       if (eq(beispiel,S(Kwild))) return FALSE;
  4555.       return equal(muster,beispiel);
  4556.       #endif
  4557.       #ifdef PATHNAME_NOEXT
  4558.       if (nullp(muster))
  4559.         { if (nullp(beispiel)) return TRUE; else return FALSE; }
  4560.       if (nullp(beispiel))
  4561.         { return FALSE; }
  4562.       return wildcard_match(muster,beispiel);
  4563.       #endif
  4564.     }
  4565.   local boolean subdir_match(muster,beispiel,logical)
  4566.     var reg2 object muster;
  4567.     var reg1 object beispiel;
  4568.     var reg3 boolean logical;
  4569.     { if (eq(muster,beispiel)) return TRUE;
  4570.       #ifdef LOGICAL_PATHNAMES
  4571.       if (logical)
  4572.         { if (eq(muster,S(Kwild))) return TRUE;
  4573.           if (!simple_string_p(muster) || !simple_string_p(beispiel)) return FALSE;
  4574.           return wildcard_match(muster,beispiel);
  4575.         }
  4576.       #endif
  4577.       #ifdef PATHNAME_EXT83
  4578.       if (atomp(muster) || atomp(beispiel)) return FALSE;
  4579.       return (nametype_match(Car(muster),Car(beispiel),FALSE)
  4580.               && nametype_match(Cdr(muster),Cdr(beispiel),FALSE)
  4581.              );
  4582.       #endif
  4583.       #ifdef PATHNAME_NOEXT
  4584.       if (!simple_string_p(muster) || !simple_string_p(beispiel)) return FALSE;
  4585.       return wildcard_match(muster,beispiel);
  4586.       #endif
  4587.     }
  4588.   # rekursive Implementation wegen Backtracking:
  4589.   local boolean directory_match_ab (object m_list, object b_list, boolean logical);
  4590.   local boolean directory_match_ab(m_list,b_list,logical)
  4591.     var reg2 object m_list;
  4592.     var reg1 object b_list;
  4593.     var reg4 boolean logical;
  4594.     { # Algorithmus analog zu wildcard_match_ab.
  4595.       var reg3 object item;
  4596.       loop
  4597.         { if (atomp(m_list)) { return atomp(b_list); }
  4598.           item = Car(m_list); m_list = Cdr(m_list);
  4599.           if (eq(item,S(Kwild_inferiors))) break;
  4600.           if (atomp(b_list)) return FALSE;
  4601.           if (!subdir_match(item,Car(b_list),logical)) return FALSE;
  4602.           b_list = Cdr(b_list);
  4603.         }
  4604.       loop
  4605.         { if (atomp(m_list)) return TRUE;
  4606.           item = Car(m_list); m_list = Cdr(m_list);
  4607.           if (!eq(item,S(Kwild_inferiors))) break;
  4608.         }
  4609.       loop
  4610.         { if (atomp(b_list)) return FALSE;
  4611.           if (subdir_match(item,Car(b_list),logical))
  4612.             { b_list = Cdr(b_list);
  4613.               if (directory_match_ab(m_list,b_list,logical)) return TRUE;
  4614.             }
  4615.             else
  4616.             { b_list = Cdr(b_list); }
  4617.         }
  4618.     }
  4619.   local boolean directory_match(muster,beispiel,logical)
  4620.     var reg2 object muster;
  4621.     var reg1 object beispiel;
  4622.     var reg3 boolean logical;
  4623.     {
  4624.       #ifdef LOGICAL_PATHNAMES
  4625.       if (!logical)
  4626.       #endif
  4627.         {
  4628.           #if HAS_SERNR
  4629.           # Seriennummer matchen:
  4630.           if (!(nullp(Car(muster)) || eql(Car(muster),Car(beispiel))))
  4631.             return FALSE;
  4632.           muster = Cdr(muster); beispiel = Cdr(beispiel);
  4633.           #endif
  4634.         }
  4635.       # Startpoint matchen:
  4636.       if (!eq(Car(muster),Car(beispiel)))
  4637.         return FALSE;
  4638.       muster = Cdr(muster); beispiel = Cdr(beispiel);
  4639.       # subdirs matchen:
  4640.       return directory_match_ab(muster,beispiel,logical);
  4641.     }
  4642.   local boolean version_match(muster,beispiel,logical)
  4643.     var reg2 object muster;
  4644.     var reg1 object beispiel;
  4645.     var reg3 boolean logical;
  4646.     {
  4647.       #ifdef LOGICAL_PATHNAMES
  4648.       if (logical)
  4649.         { if (eq(muster,S(Kwild))) return TRUE;
  4650.           return eql(muster,beispiel);
  4651.         }
  4652.       #endif
  4653.       #if HAS_VERSION
  4654.       if (eq(muster,S(Kwild))) return TRUE;
  4655.       if (eq(beispiel,S(Kwild))) return FALSE;
  4656.       if (eql(muster,beispiel)) return TRUE;
  4657.       return FALSE;
  4658.       #else
  4659.       return TRUE;
  4660.       #endif
  4661.     }
  4662.  
  4663. LISPFUNN(pathname_match_p,2)
  4664. # (PATHNAME-MATCH-P pathname wildname), CLtL2 S. 623
  4665.   { # Stackaufbau: pathname, wildname.
  4666.     var reg3 boolean logical = FALSE;
  4667.     STACK_1 = coerce_xpathname(STACK_1);
  4668.     STACK_0 = coerce_xpathname(STACK_0);
  4669.     #ifdef LOGICAL_PATHNAMES
  4670.     if (logpathnamep(STACK_1) && logpathnamep(STACK_0))
  4671.       { logical = TRUE; }
  4672.       else
  4673.       # nicht beides logische Pathnames -> erst in normale Pathnames umwandeln:
  4674.       { STACK_1 = coerce_pathname(STACK_1);
  4675.         STACK_0 = coerce_pathname(STACK_0);
  4676.       }
  4677.     #endif
  4678.    {var reg2 object wildname = popSTACK();
  4679.     var reg1 object pathname = popSTACK();
  4680.     if (!host_match(xpathname_host(logical,wildname),
  4681.                     xpathname_host(logical,pathname),
  4682.                     logical
  4683.        )           )
  4684.       goto no;
  4685.     if (!device_match(xpathname_device(logical,wildname),
  4686.                       xpathname_device(logical,pathname),
  4687.                       logical
  4688.        )             )
  4689.       goto no;
  4690.     if (!directory_match(xpathname_directory(logical,wildname),
  4691.                          xpathname_directory(logical,pathname),
  4692.                          logical
  4693.        )                )
  4694.       goto no;
  4695.     if (!nametype_match(xpathname_name(logical,wildname),
  4696.                         xpathname_name(logical,pathname),
  4697.                         logical
  4698.        )               )
  4699.       goto no;
  4700.     if (!nametype_match(xpathname_type(logical,wildname),
  4701.                         xpathname_type(logical,pathname),
  4702.                         logical
  4703.        )               )
  4704.       goto no;
  4705.     if (!version_match(xpathname_version(logical,wildname),
  4706.                        xpathname_version(logical,pathname),
  4707.                        logical
  4708.        )              )
  4709.       goto no;
  4710.     yes: value1 = T; mv_count=1; return;
  4711.     no: value1 = NIL; mv_count=1; return;
  4712.   }}
  4713.  
  4714. # (TRANSLATE-PATHNAME beispiel muster1 muster2) machen wir folgenderma▀en:
  4715. # 1. (PATHNAME-MATCH-P beispiel muster1) nachrechnen, dabei aber die
  4716. #    Substitution aufheben, in Form von Textstⁿcken (:WILD -> "*").
  4717. # 2. In muster2 die Textstⁿcke einsetzen, bis muster2 voll ist oder die
  4718. #    Textstⁿcke aufgebraucht sind.
  4719. # 3. Zum Schlu▀ (MERGE-PATHNAMES modifiziertes_muster2 beispiel).
  4720.  
  4721.   # UP: Vergleicht einen Wildcard-String ("Muster") mit einem "Beispiel".
  4722.   # wildcard_diff(muster,beispiel,previous,solutions);
  4723.   # > muster: Simple-String, mit Platzhaltern
  4724.   #           '?' fⁿr genau 1 Zeichen
  4725.   #           '*' fⁿr beliebig viele Zeichen
  4726.   # > beispiel: Simple-String, der damit zu vergleichen ist
  4727.   # > previous: bisher bekanntes Vergleichsergebnis
  4728.   #             (umgedrehte Liste von Simple-Strings und Listen)
  4729.   # > solutions: Pointer auf eine Liste im STACK, auf die die
  4730.   #              Vergleichsergebnisse (umgedrehte Liste von Simple-Strings und
  4731.   #              Listen) zu consen sind
  4732.   # kann GC ausl÷sen
  4733.  
  4734.   # Hier wⁿnscht man sich nicht Lisp oder C, sondern PROLOG als Sprache!
  4735.  
  4736.   #define push_solution()  \
  4737.     { var reg1 object new_cons = allocate_cons(); \
  4738.       Car(new_cons) = *previous;                  \
  4739.       Cdr(new_cons) = *solutions;                 \
  4740.       *solutions = new_cons;                      \
  4741.     }
  4742.   #define push_solution_with(new_piece)  \
  4743.     { pushSTACK(new_piece);                                   \
  4744.      {var reg1 object new_cons = allocate_cons();             \
  4745.       Car(new_cons) = STACK_0; Cdr(new_cons) = *previous;     \
  4746.       STACK_0 = new_cons;                                     \
  4747.       new_cons = allocate_cons();                             \
  4748.       Car(new_cons) = popSTACK(); Cdr(new_cons) = *solutions; \
  4749.       *solutions = new_cons;                                  \
  4750.     }}
  4751.  
  4752. #if defined(PATHNAME_NOEXT) || defined(LOGICAL_PATHNAMES)
  4753.  
  4754.   local void wildcard_diff (object muster, object beispiel, object* previous, object* solutions);
  4755.  
  4756.   # rekursive Implementation wegen Backtracking:
  4757.   local void wildcard_diff_ab (object muster, object beispiel, uintL m_index, uintL b_index, object* previous, object* solutions);
  4758.  
  4759.   local void wildcard_diff(muster,beispiel,previous,solutions)
  4760.     var reg2 object muster;
  4761.     var reg1 object beispiel;
  4762.     var reg4 object* previous;
  4763.     var reg3 object* solutions;
  4764.     { wildcard_diff_ab(muster,beispiel,0,0,previous,solutions); }
  4765.  
  4766.   local void wildcard_diff_ab(muster,beispiel,m_index,b_index,previous,solutions)
  4767.     var reg3 object muster;
  4768.     var reg2 object beispiel;
  4769.     var reg6 uintL m_index;
  4770.     var reg5 uintL b_index;
  4771.     var reg8 object* previous;
  4772.     var reg7 object* solutions;
  4773.     { var reg4 uintB c;
  4774.       loop
  4775.         { if (m_index == TheSstring(muster)->length)
  4776.             { if (b_index == TheSstring(beispiel)->length)
  4777.                 { push_solution(); }
  4778.               return;
  4779.             }
  4780.           c = TheSstring(muster)->data[m_index++];
  4781.           if (c=='*') break;
  4782.           if (b_index == TheSstring(beispiel)->length) return;
  4783.           if (c=='?')
  4784.             { # wildcard_diff_ab() rekursiv aufrufen, mit erweitertem previous:
  4785.               c = TheSstring(beispiel)->data[b_index++];
  4786.               pushSTACK(muster); pushSTACK(beispiel);
  4787.               { var reg1 object new_string = allocate_string(1);
  4788.                 TheSstring(new_string)->data[0] = c;
  4789.                 pushSTACK(new_string);
  4790.               }
  4791.               { var reg1 object new_cons = allocate_cons();
  4792.                 Car(new_cons) = STACK_0; Cdr(new_cons) = *previous;
  4793.                 STACK_0 = new_cons; # (CONS ... previous)
  4794.               }
  4795.               wildcard_diff_ab(STACK_2,STACK_1,m_index,b_index,&STACK_0,solutions);
  4796.               skipSTACK(3);
  4797.               return;
  4798.             }
  4799.             else
  4800.             { if (!equal_pathchar(TheSstring(beispiel)->data[b_index++],c))
  4801.                 return;
  4802.             }
  4803.         }
  4804.      {var reg9 uintL b_start_index = b_index;
  4805.       loop
  4806.         { # Um weniger zu consen, die FΣlle abfangen, wo wildcard_diff_ab()
  4807.           # gar nichts tut:
  4808.           if (m_index == TheSstring(muster)->length
  4809.               ? b_index == TheSstring(beispiel)->length
  4810.               : (c = TheSstring(muster)->data[m_index],
  4811.                  (c=='*') || (c=='?')
  4812.                  || (b_index < TheSstring(beispiel)->length
  4813.                      && equal_pathchar(TheSstring(beispiel)->data[b_index],c)
  4814.              )  )   )
  4815.             # wildcard_diff_ab() rekursiv aufrufen, mit erweitertem previous:
  4816.             { pushSTACK(muster); pushSTACK(beispiel);
  4817.               pushSTACK(beispiel); pushSTACK(fixnum(b_start_index)); pushSTACK(fixnum(b_index));
  4818.               funcall(L(substring),3); # (SUBSTRING beispiel b_start_index b_index)
  4819.               pushSTACK(value1);
  4820.              {var reg1 object new_cons = allocate_cons();
  4821.               Car(new_cons) = STACK_0; Cdr(new_cons) = *previous;
  4822.               STACK_0 = new_cons; # (CONS ... previous)
  4823.               wildcard_diff_ab(STACK_2,STACK_1,m_index,b_index,&STACK_0,solutions);
  4824.               skipSTACK(1);
  4825.               beispiel = popSTACK(); muster = popSTACK();
  4826.             }}
  4827.           if (b_index == TheSstring(beispiel)->length)
  4828.             break;
  4829.           b_index++;
  4830.         }
  4831.     }}
  4832.  
  4833. #endif
  4834.  
  4835. # UPs: Vergleicht jeweils eine Pathname-Komponente ("Beispiel") und
  4836. # eine Pathname-Komponente ("Muster").
  4837. # kann GC ausl÷sen
  4838.   local void host_diff (object muster, object beispiel, boolean logical, object* previous, object* solutions);
  4839.   local void device_diff (object muster, object beispiel, boolean logical, object* previous, object* solutions);
  4840.   local void directory_diff (object muster, object beispiel, boolean logical, object* previous, object* solutions);
  4841.   local void nametype_diff (object muster, object beispiel, boolean logical, object* previous, object* solutions);
  4842.   local void version_diff (object muster, object beispiel, boolean logical, object* previous, object* solutions);
  4843.   local void host_diff(muster,beispiel,logical,previous,solutions)
  4844.     var reg2 object muster;
  4845.     var reg1 object beispiel;
  4846.     var reg5 boolean logical;
  4847.     var reg4 object* previous;
  4848.     var reg3 object* solutions;
  4849.     {
  4850.       #ifdef LOGICAL_PATHNAMES
  4851.       if (logical)
  4852.         { if (!equal(muster,beispiel)) return; }
  4853.         else
  4854.       #endif
  4855.         {
  4856.           #if HAS_HOST
  4857.           if (!equal(muster,beispiel)) return;
  4858.           #endif
  4859.         }
  4860.       push_solution();
  4861.     }
  4862.   local void device_diff(muster,beispiel,logical,previous,solutions)
  4863.     var reg2 object muster;
  4864.     var reg1 object beispiel;
  4865.     var reg5 boolean logical;
  4866.     var reg4 object* previous;
  4867.     var reg3 object* solutions;
  4868.     {
  4869.       #if HAS_DEVICE
  4870.       #ifdef LOGICAL_PATHNAMES
  4871.       if (logical)
  4872.         { push_solution(); return; }
  4873.       #endif
  4874.       #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  4875.       if (eq(muster,S(Kwild)))
  4876.         { var reg1 object string =
  4877.             (eq(beispiel,S(Kwild)) ? O(wild_string) :
  4878.              simple_string_p(beispiel) ? beispiel : O(leer_string)
  4879.             );
  4880.           push_solution_with(string);
  4881.           return;
  4882.         }
  4883.       if (eq(beispiel,S(Kwild))) return;
  4884.       #endif
  4885.       #if defined(PATHNAME_AMIGAOS) || defined(PATHNAME_OS2)
  4886.       if (!equalp(muster,beispiel)) return;
  4887.       #else
  4888.       if (!equal(muster,beispiel)) return;
  4889.       #endif
  4890.       #endif
  4891.       push_solution();
  4892.     }
  4893.   local void nametype_diff(muster,beispiel,logical,previous,solutions)
  4894.     var reg2 object muster;
  4895.     var reg1 object beispiel;
  4896.     var reg5 boolean logical;
  4897.     var reg4 object* previous;
  4898.     var reg3 object* solutions;
  4899.     {
  4900.       #ifdef LOGICAL_PATHNAMES
  4901.       if (logical)
  4902.         { if (eq(muster,S(Kwild)))
  4903.             { var reg1 object string =
  4904.                 (eq(beispiel,S(Kwild)) ? O(wild_string) :
  4905.                  simple_string_p(beispiel) ? beispiel : O(leer_string)
  4906.                 );
  4907.               push_solution_with(string);
  4908.               return;
  4909.             }
  4910.           if (eq(beispiel,S(Kwild))) return;
  4911.           if (nullp(muster))
  4912.             { if (nullp(beispiel))
  4913.                 { push_solution(); }
  4914.               return;
  4915.             }
  4916.           if (nullp(beispiel))
  4917.             return;
  4918.           wildcard_diff(muster,beispiel,previous,solutions);
  4919.           return;
  4920.         }
  4921.       #endif
  4922.       #ifdef PATHNAME_EXT83
  4923.       if (eq(muster,S(Kwild)))
  4924.         { var reg1 object string =
  4925.             (eq(beispiel,S(Kwild)) ? O(wild_string) :
  4926.              simple_string_p(beispiel) ? beispiel : O(leer_string)
  4927.             );
  4928.           push_solution_with(string);
  4929.           return;
  4930.         }
  4931.       if (eq(beispiel,S(Kwild))) return;
  4932.       if (!equal(muster,beispiel)) return;
  4933.       push_solution();
  4934.       #endif
  4935.       #ifdef PATHNAME_NOEXT
  4936.       if (nullp(muster))
  4937.         { if (nullp(beispiel))
  4938.             { push_solution(); }
  4939.           return;
  4940.         }
  4941.       if (nullp(beispiel))
  4942.         return;
  4943.       wildcard_diff(muster,beispiel,previous,solutions);
  4944.       #endif
  4945.     }
  4946.   local void subdir_diff(muster,beispiel,logical,previous,solutions)
  4947.     var reg2 object muster;
  4948.     var reg1 object beispiel;
  4949.     var reg5 boolean logical;
  4950.     var reg4 object* previous;
  4951.     var reg3 object* solutions;
  4952.     { if (eq(muster,beispiel))
  4953.         { if (eq(beispiel,S(Kwild)))
  4954.             { push_solution_with(O(wild_string)); }
  4955.             else
  4956.             { push_solution(); }
  4957.           return;
  4958.         }
  4959.       #ifdef LOGICAL_PATHNAMES
  4960.       if (logical)
  4961.         { if (eq(muster,S(Kwild)))
  4962.             { var reg1 object string =
  4963.                 (eq(beispiel,S(Kwild)) ? O(wild_string) :
  4964.                  simple_string_p(beispiel) ? beispiel : O(leer_string)
  4965.                 );
  4966.               push_solution_with(string);
  4967.               return;
  4968.             }
  4969.           if (eq(beispiel,S(Kwild))) return;
  4970.           if (!simple_string_p(muster) || !simple_string_p(beispiel)) return;
  4971.           wildcard_diff(muster,beispiel,previous,solutions);
  4972.           return;
  4973.         }
  4974.       #endif
  4975.       #ifdef PATHNAME_EXT83
  4976.       if (atomp(muster) || atomp(beispiel)) return;
  4977.       pushSTACK(NIL); pushSTACK(Cdr(muster)); pushSTACK(Cdr(beispiel));
  4978.       nametype_diff(Car(muster),Car(beispiel),FALSE,previous,&STACK_2);
  4979.       while (mconsp(STACK_2))
  4980.         { pushSTACK(Car(STACK_2));
  4981.           nametype_diff(STACK_(1+1),STACK_(0+1),FALSE,&STACK_0,solutions);
  4982.           skipSTACK(1);
  4983.           STACK_2 = Cdr(STACK_2);
  4984.         }
  4985.       skipSTACK(3);
  4986.       #endif
  4987.       #ifdef PATHNAME_NOEXT
  4988.       if (!simple_string_p(muster) || !simple_string_p(beispiel)) return;
  4989.       wildcard_diff(muster,beispiel,previous,solutions);
  4990.       #endif
  4991.     }
  4992.   # rekursive Implementation wegen Backtracking:
  4993.   local void directory_diff_ab (object m_list, object b_list, boolean logical, object* previous, object* solutions);
  4994.   local void directory_diff_ab(m_list,b_list,logical,previous,solutions)
  4995.     var reg3 object m_list;
  4996.     var reg2 object b_list;
  4997.     var reg8 boolean logical;
  4998.     var reg6 object* previous;
  4999.     var reg7 object* solutions;
  5000.     { # Algorithmus analog zu wildcard_diff_ab.
  5001.       var reg4 object item;
  5002.       if (atomp(m_list))
  5003.         { if (atomp(b_list))
  5004.             { push_solution(); }
  5005.           return;
  5006.         }
  5007.       item = Car(m_list); m_list = Cdr(m_list);
  5008.       if (!eq(item,S(Kwild_inferiors)))
  5009.         { if (atomp(b_list)) return;
  5010.           pushSTACK(NIL); pushSTACK(m_list); pushSTACK(Cdr(b_list));
  5011.           subdir_diff(item,Car(b_list),logical,previous,&STACK_2);
  5012.           # directory_diff_ab() rekursiv aufrufen, mit erweitertem previous:
  5013.           while (mconsp(STACK_2))
  5014.             { pushSTACK(Car(STACK_2));
  5015.               directory_diff_ab(STACK_(1+1),STACK_(0+1),logical,&STACK_0,solutions);
  5016.               skipSTACK(1);
  5017.               STACK_2 = Cdr(STACK_2);
  5018.             }
  5019.           skipSTACK(3);
  5020.         }
  5021.         else
  5022.         { pushSTACK(b_list); # b_start_list := b_list
  5023.           loop
  5024.             { # Um weniger zu consen, die FΣlle abfangen, wo directory_diff_ab()
  5025.               # gar nichts tut:
  5026.               if (atomp(m_list)
  5027.                   ? atomp(b_list)
  5028.                   : (eq(Car(m_list),S(Kwild_inferiors)) || !atomp(b_list))
  5029.                  )
  5030.                 # directory_diff_ab() rekursiv aufrufen, mit erweitertem previous:
  5031.                 { pushSTACK(m_list); pushSTACK(b_list);
  5032.                   pushSTACK(STACK_2); pushSTACK(b_list);
  5033.                   funcall(L(ldiff),2); # (LDIFF b_start_list b_list)
  5034.                   pushSTACK(value1);
  5035.                  {var reg1 object new_cons = allocate_cons();
  5036.                   Car(new_cons) = STACK_0; Cdr(new_cons) = *previous;
  5037.                   STACK_0 = new_cons; # (CONS ... previous)
  5038.                   directory_diff_ab(STACK_2,STACK_1,logical,&STACK_0,solutions);
  5039.                   skipSTACK(1);
  5040.                   b_list = popSTACK(); m_list = popSTACK();
  5041.                 }}
  5042.               if (atomp(b_list)) break;
  5043.               b_list = Cdr(b_list);
  5044.             }
  5045.           skipSTACK(1);
  5046.         }
  5047.     }
  5048.   local void directory_diff(muster,beispiel,logical,previous,solutions)
  5049.     var reg2 object muster;
  5050.     var reg1 object beispiel;
  5051.     var reg5 boolean logical;
  5052.     var reg4 object* previous;
  5053.     var reg3 object* solutions;
  5054.     {
  5055.       #ifdef LOGICAL_PATHNAMES
  5056.       if (!logical)
  5057.       #endif
  5058.         {
  5059.           #if HAS_SERNR
  5060.           # Seriennummer vergleichen:
  5061.           if (!(nullp(Car(muster)) || eql(Car(muster),Car(beispiel))))
  5062.             return;
  5063.           muster = Cdr(muster); beispiel = Cdr(beispiel);
  5064.           #endif
  5065.         }
  5066.       # Startpoint vergleichen:
  5067.       if (!eq(Car(muster),Car(beispiel)))
  5068.         return;
  5069.       muster = Cdr(muster); beispiel = Cdr(beispiel);
  5070.       # subdirs vergleichen:
  5071.       directory_diff_ab(muster,beispiel,logical,previous,solutions);
  5072.     }
  5073.   local void version_diff(muster,beispiel,logical,previous,solutions)
  5074.     var reg2 object muster;
  5075.     var reg1 object beispiel;
  5076.     var reg5 boolean logical;
  5077.     var reg4 object* previous;
  5078.     var reg3 object* solutions;
  5079.     {
  5080.       #ifdef LOGICAL_PATHNAMES
  5081.       if (logical)
  5082.         { if (eq(muster,S(Kwild)))
  5083.             { var reg1 object string =
  5084.                 (eq(beispiel,S(Kwild)) ? O(wild_string) :
  5085.                  integerp(beispiel) ? (pushSTACK(beispiel), C_decimal_string(), value1) : # (SYS::DECIMAL-STRING beispiel)
  5086.                  O(leer_string)
  5087.                 );
  5088.               push_solution_with(string);
  5089.               return;
  5090.             }
  5091.           if (eq(beispiel,S(Kwild))) return;
  5092.           if (!eql(muster,beispiel)) return;
  5093.           push_solution();
  5094.           return;
  5095.         }
  5096.       #endif
  5097.       #if HAS_VERSION
  5098.       if (eq(muster,S(Kwild)))
  5099.         { var reg1 object string =
  5100.             (eq(beispiel,S(Kwild)) ? O(wild_string) :
  5101.              integerp(beispiel) ? (pushSTACK(beispiel), C_decimal_string(), value1) : # (SYS::DECIMAL-STRING beispiel)
  5102.              O(leer_string)
  5103.             );
  5104.           push_solution_with(string);
  5105.           return;
  5106.         }
  5107.       if (eq(beispiel,S(Kwild))) return;
  5108.       if (!eql(muster,beispiel)) return;
  5109.       #endif
  5110.       push_solution();
  5111.     }
  5112.  
  5113.   #undef push_solution_with
  5114.   #undef push_solution
  5115.  
  5116. # Jede Substitution ist eine Liste von Simple-Strings oder Listen.
  5117. # (Die Listen entstehen bei :WILD-INFERIORS in directory_diff().)
  5118. # Ein Simple-String pa▀t nur auf '?' oder '*' oder :WILD,
  5119. # eine Liste pa▀t nur auf :WILD-INFERIORS.
  5120.  
  5121. #ifdef LOGICAL_PATHNAMES
  5122.  
  5123. # Beim Einsetzen von Stⁿcken normaler Pathnames in logische Pathnames:
  5124. # Umwandlung in Gro▀buchstaben.
  5125. # logical_case(string)
  5126. # > string: Simple-String oder Symbol/Zahl
  5127. # < ergebnis: umgewandelter Simple-String oder dasselbe Symbol/Zahl
  5128. # kann GC ausl÷sen
  5129.   local object logical_case (object string);
  5130. # Dasselbe, rekursiv wie mit SUBST:
  5131.   local object subst_logical_case (object obj);
  5132. #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS)
  5133.   # sowieso schon alles Gro▀buchstaben
  5134.   #define logical_case(string)  string
  5135.   #define subst_logical_case(obj)  obj
  5136. #else
  5137.   local object logical_case(string)
  5138.     var reg1 object string;
  5139.     { if (!simple_string_p(string))
  5140.         return string;
  5141.       return string_upcase(string);
  5142.     }
  5143.   local object subst_logical_case(obj)
  5144.     var reg1 object obj;
  5145.     { if (atomp(obj))
  5146.         { return logical_case(obj); }
  5147.       check_STACK(); check_SP();
  5148.       pushSTACK(obj);
  5149.       # rekursiv fⁿr den CAR aufrufen:
  5150.       { var reg2 object new_car = subst_logical_case(Car(obj));
  5151.         pushSTACK(new_car);
  5152.       }
  5153.       # rekursiv fⁿr den CDR aufrufen:
  5154.       { var reg2 object new_cdr = subst_logical_case(Cdr(STACK_1));
  5155.         if (eq(new_cdr,Cdr(STACK_1)) && eq(STACK_0,Car(STACK_1)))
  5156.           { obj = STACK_1; skipSTACK(2); return obj; }
  5157.           else
  5158.           # (CONS new_car new_cdr)
  5159.           { STACK_1 = new_cdr;
  5160.            {var reg1 object new_cons = allocate_cons();
  5161.             Car(new_cons) = popSTACK(); Cdr(new_cons) = popSTACK();
  5162.             return new_cons;
  5163.     } }   }}
  5164. #endif
  5165.  
  5166. # Beim Einsetzen von Stⁿcken logischer Pathnames in normale Pathnames:
  5167. # Umwandlung in Gro▀buchstaben.
  5168. # logical_case(string)
  5169. # > string: Simple-String oder Symbol/Zahl
  5170. # < ergebnis: umgewandelter Simple-String oder dasselbe Symbol/Zahl
  5171. # kann GC ausl÷sen
  5172.   local object customary_case (object string);
  5173. # Dasselbe, rekursiv wie mit SUBST:
  5174.   local object subst_customary_case (object obj);
  5175. #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS)
  5176.   # Betriebssystem mit Vorzug fⁿr Gro▀buchstaben
  5177.   #define customary_case(string)  string
  5178.   #define subst_customary_case(obj)  obj
  5179. #else
  5180.   local object customary_case(string)
  5181.     var reg1 object string;
  5182.     { if (!simple_string_p(string))
  5183.         return string;
  5184.       #if defined(PATHNAME_UNIX) || defined(PATHNAME_OS2) || defined(PATHNAME_RISCOS)
  5185.       # Betriebssystem mit Vorzug fⁿr Kleinbuchstaben
  5186.       return string_downcase(string);
  5187.       #endif
  5188.       #ifdef PATHNAME_AMIGAOS
  5189.       # Betriebssystem mit Vorzug fⁿr Capitalize
  5190.       string = copy_string(string);
  5191.       nstring_capitalize(&TheSstring(string)->data[0],TheSstring(string)->length);
  5192.       return string;
  5193.       #endif
  5194.     }
  5195.   local object subst_customary_case(obj)
  5196.     var reg1 object obj;
  5197.     { if (atomp(obj))
  5198.         { return customary_case(obj); }
  5199.       check_STACK(); check_SP();
  5200.       pushSTACK(obj);
  5201.       # rekursiv fⁿr den CAR aufrufen:
  5202.       { var reg2 object new_car = subst_customary_case(Car(obj));
  5203.         pushSTACK(new_car);
  5204.       }
  5205.       # rekursiv fⁿr den CDR aufrufen:
  5206.       { var reg2 object new_cdr = subst_customary_case(Cdr(STACK_1));
  5207.         if (eq(new_cdr,Cdr(STACK_1)) && eq(STACK_0,Car(STACK_1)))
  5208.           { obj = STACK_1; skipSTACK(2); return obj; }
  5209.           else
  5210.           # (CONS new_car new_cdr)
  5211.           { STACK_1 = new_cdr;
  5212.            {var reg1 object new_cons = allocate_cons();
  5213.             Car(new_cons) = popSTACK(); Cdr(new_cons) = popSTACK();
  5214.             return new_cons;
  5215.     } }   }}
  5216. #endif
  5217.  
  5218. #endif
  5219.  
  5220. # UP: Eine Substitution auf ein Muster anwenden.
  5221. # translate_pathname(&subst,muster)
  5222.   local object translate_pathname (object* subst, object muster);
  5223. # translate_host(&subst,muster,logical) etc. liefert den host etc. mit Ersetzungen
  5224. # und verkⁿrzen subst passend. Falls nicht passend, liefert es nullobj.
  5225.   local object translate_host (object* subst, object muster, boolean logical);
  5226.   local object translate_device (object* subst, object muster, boolean logical);
  5227.   local object translate_subdir (object* subst, object muster, boolean logical);
  5228.   local object translate_directory (object* subst, object muster, boolean logical);
  5229.   local object translate_nametype (object* subst, object muster, boolean logical);
  5230.   local object translate_version (object* subst, object muster, boolean logical);
  5231.   #define translate_host(subst,muster,logical)  (muster)
  5232.   local object translate_device(subst,muster,logical)
  5233.     var reg1 object* subst;
  5234.     var reg2 object muster;
  5235.     var reg4 boolean logical;
  5236.     {
  5237.       #if HAS_DEVICE
  5238.       #ifdef LOGICAL_PATHNAMES
  5239.       if (logical)
  5240.         { return muster; }
  5241.       #endif
  5242.       if (eq(muster,S(Kwild)) && mconsp(*subst))
  5243.         { if (m_simple_string_p(Car(*subst)))
  5244.             { var reg3 object erg = Car(*subst); *subst = Cdr(*subst);
  5245.               return erg;
  5246.             }
  5247.             else
  5248.             return nullobj;
  5249.         }
  5250.       #endif
  5251.       return muster;
  5252.     }
  5253.   local object translate_nametype(subst,muster,logical)
  5254.     var reg6 object* subst;
  5255.     var reg3 object muster;
  5256.     var reg7 boolean logical;
  5257.     { if (eq(muster,S(Kwild)) && mconsp(*subst))
  5258.         { if (m_simple_string_p(Car(*subst)))
  5259.             { var reg3 object erg = Car(*subst); *subst = Cdr(*subst);
  5260.               return erg;
  5261.             }
  5262.             else
  5263.             return nullobj;
  5264.         }
  5265.       if (simple_string_p(muster))
  5266.         { pushSTACK(muster); # muster retten
  5267.          {var reg5 object* muster_ = &STACK_0;
  5268.           var reg4 uintL len = TheSstring(muster)->length;
  5269.           var reg1 uintL index = 0;
  5270.           var reg7 uintL stringcount = 0; # Anzahl der Strings auf dem Stack
  5271.           loop
  5272.             { var reg9 uintL last_index = index;
  5273.               var reg2 uintB c;
  5274.               # Suche nΣchstes Wildcard-Zeichen:
  5275.               muster = *muster_;
  5276.               loop
  5277.                 { if (index == len) break;
  5278.                   c = TheSstring(muster)->data[index];
  5279.                   if (((c=='*') # Wildcard fⁿr beliebig viele Zeichen
  5280.                        || (!logical && singlewild_char_p(c)) # Wildcard fⁿr genau ein Zeichen
  5281.                       )
  5282.                       && mconsp(*subst)
  5283.                      )
  5284.                     break;
  5285.                   index++;
  5286.                 }
  5287.               # NΣchsten Teilstring auf den Stack:
  5288.               pushSTACK(muster); pushSTACK(fixnum(last_index)); pushSTACK(fixnum(index));
  5289.               funcall(L(substring),3); # (SUBSTRING muster last_index index)
  5290.               pushSTACK(value1); stringcount++;
  5291.               # Fertig?
  5292.               if (index == len) break;
  5293.               # Wildcard ersetzen:
  5294.               if (m_simple_string_p(Car(*subst)))
  5295.                 { pushSTACK(Car(*subst)); *subst = Cdr(*subst); stringcount++; }
  5296.                 else
  5297.                 { skipSTACK(stringcount+1); return nullobj; }
  5298.               index++;
  5299.             }
  5300.           funcall(L(string_concat),stringcount); # (STRING-CONCAT alle Strings)
  5301.           skipSTACK(1);
  5302.           return value1;
  5303.         }}
  5304.       return muster;
  5305.     }
  5306.   local object translate_subdir(subst,muster,logical)
  5307.     var reg3 object* subst;
  5308.     var reg2 object muster;
  5309.     var reg4 boolean logical;
  5310.     {
  5311.       #ifdef LOGICAL_PATHNAMES
  5312.       if (logical)
  5313.         { return translate_nametype(subst,muster,logical); }
  5314.       #endif
  5315.       #ifdef PATHNAME_EXT83
  5316.       if (atomp(muster)) return muster;
  5317.       pushSTACK(Car(muster)); pushSTACK(Cdr(muster));
  5318.       if (eq(STACK_1 = translate_nametype(subst,STACK_1,FALSE),nullobj)
  5319.           || eq(STACK_0 = translate_nametype(subst,STACK_0,FALSE),nullobj)
  5320.          )
  5321.         { skipSTACK(2); return nullobj; }
  5322.       {var reg1 object new_cons = allocate_cons();
  5323.        Car(new_cons) = STACK_1; Cdr(new_cons) = STACK_0; skipSTACK(2);
  5324.        return new_cons;
  5325.       }
  5326.       #endif
  5327.       #ifdef PATHNAME_NOEXT
  5328.       return translate_nametype(subst,muster,FALSE);
  5329.       #endif
  5330.     }
  5331.   local object translate_directory(subst,muster,logical)
  5332.     var reg2 object* subst;
  5333.     var reg4 object muster;
  5334.     var reg6 boolean logical;
  5335.     { var reg5 uintL itemcount = 0; # Anzahl der Elemente auf dem Stack
  5336.       #ifdef LOGICAL_PATHNAMES
  5337.       if (!logical)
  5338.       #endif
  5339.         {
  5340.           #if HAS_SERNR
  5341.           # Seriennummer:
  5342.           pushSTACK(Car(muster)); muster = Cdr(muster); itemcount++;
  5343.           #endif
  5344.         }
  5345.       # Startpoint:
  5346.       pushSTACK(Car(muster)); muster = Cdr(muster); itemcount++;
  5347.       # subdirs:
  5348.       while (consp(muster))
  5349.         { var reg3 object item = Car(muster);
  5350.           muster = Cdr(muster);
  5351.           if (eq(item,S(Kwild_inferiors)))
  5352.             { if (mconsp(*subst))
  5353.                 { if (listp(Car(*subst)))
  5354.                     { var reg1 object list = Car(*subst); *subst = Cdr(*subst);
  5355.                       while (consp(list))
  5356.                         { pushSTACK(Car(list)); list = Cdr(list); itemcount++; }
  5357.                     }
  5358.                     else
  5359.                     { skipSTACK(itemcount); return nullobj; }
  5360.                 }
  5361.                 else
  5362.                 { pushSTACK(item); itemcount++; }
  5363.             }
  5364.             else
  5365.             { pushSTACK(muster); # muster retten
  5366.               item = translate_subdir(subst,item,logical);
  5367.               if (eq(item,nullobj)) { skipSTACK(itemcount+1); return nullobj; }
  5368.               muster = STACK_0; STACK_0 = item; itemcount++;
  5369.             }
  5370.         }
  5371.       return listof(itemcount);
  5372.     }
  5373.   local object translate_version(subst,muster,logical)
  5374.     var reg1 object* subst;
  5375.     var reg2 object muster;
  5376.     var reg4 boolean logical;
  5377.     {
  5378.       #ifdef LOGICAL_PATHNAMES
  5379.       if (logical)
  5380.         { if (eq(muster,S(Kwild)) && mconsp(*subst))
  5381.             { if (m_simple_string_p(Car(*subst)))
  5382.                 { var reg3 object erg = Car(*subst); *subst = Cdr(*subst);
  5383.                   pushSTACK(erg); funcall(L(parse_integer),1);
  5384.                   return value1;
  5385.                 }
  5386.                 else
  5387.                 return nullobj;
  5388.             }
  5389.           return muster;
  5390.         }
  5391.       #endif
  5392.       #if HAS_VERSION
  5393.       if (eq(muster,S(Kwild)) && mconsp(*subst))
  5394.         { if (m_simple_string_p(Car(*subst)))
  5395.             { var reg3 object erg = Car(*subst); *subst = Cdr(*subst);
  5396.               pushSTACK(erg); funcall(L(parse_integer),1);
  5397.               return value1;
  5398.             }
  5399.             else
  5400.             return nullobj;
  5401.         }
  5402.       #endif
  5403.       return muster;
  5404.     }
  5405.   local object translate_pathname(subst,muster)
  5406.     var reg2 object* subst;
  5407.     var reg3 object muster;
  5408.     { var reg4 boolean logical = FALSE;
  5409.       var reg1 object item;
  5410.       pushSTACK(*subst); # subst retten fⁿr Fehlermeldung
  5411.       pushSTACK(muster);
  5412.       #ifdef LOGICAL_PATHNAMES
  5413.       if (logpathnamep(muster)) { logical = TRUE; }
  5414.       #endif
  5415.       # Argumente fⁿr MAKE-PATHNAME zusammenbauen:
  5416.       #if 1 # HAS_HOST || defined(LOGICAL_PATHNAMES)
  5417.       item = translate_host(subst,xpathname_host(logical,muster),logical);
  5418.       if (eq(item,nullobj)) { goto error; }
  5419.       pushSTACK(S(Khost)); pushSTACK(item);
  5420.       #endif
  5421.       #if HAS_DEVICE
  5422.       item = translate_device(subst,xpathname_device(logical,STACK_2),logical);
  5423.       if (eq(item,nullobj)) { skipSTACK(2); goto error; }
  5424.       pushSTACK(S(Kdevice)); pushSTACK(item);
  5425.       #endif
  5426.       item = translate_directory(subst,xpathname_directory(logical,STACK_(2+2*HAS_DEVICE)),logical);
  5427.       if (eq(item,nullobj)) { skipSTACK(2+2*HAS_DEVICE); goto error; }
  5428.       pushSTACK(S(Kdirectory)); pushSTACK(item);
  5429.       item = translate_nametype(subst,xpathname_name(logical,STACK_(2+2*HAS_DEVICE+2)),logical);
  5430.       if (eq(item,nullobj)) { skipSTACK(2+2*HAS_DEVICE+2); goto error; }
  5431.       pushSTACK(S(Kname)); pushSTACK(item);
  5432.       item = translate_nametype(subst,xpathname_type(logical,STACK_(2+2*HAS_DEVICE+4)),logical);
  5433.       if (eq(item,nullobj)) { skipSTACK(2+2*HAS_DEVICE+4); goto error; }
  5434.       pushSTACK(S(Ktype)); pushSTACK(item);
  5435.       #if 1 # HAS_VERSION || defined(LOGICAL_PATHNAMES)
  5436.       item = translate_version(subst,xpathname_version(logical,STACK_(2+2*HAS_DEVICE+6)),logical);
  5437.       if (eq(item,nullobj)) { skipSTACK(2+2*HAS_DEVICE+6); goto error; }
  5438.       pushSTACK(S(Kversion)); pushSTACK(item);
  5439.       #endif
  5440.       # Alle Ersetzungsstⁿcke mⁿssen verbraucht werden!
  5441.       if (mconsp(*subst)) { skipSTACK(2+2*HAS_DEVICE+8); goto error; }
  5442.       # (MAKE-PATHNAME ...) bzw. (SYS::MAKE-LOGICAL-PATHNAME ...) aufrufen:
  5443.       #ifdef LOGICAL_PATHNAMES
  5444.       if (logical)
  5445.         funcall(L(make_logical_pathname),2+2*HAS_DEVICE+8);
  5446.         else
  5447.       #endif
  5448.         funcall(L(make_pathname),2+2*HAS_DEVICE+8);
  5449.       skipSTACK(2);
  5450.       return value1;
  5451.      error: # Error wegen nullobj.
  5452.       # Stackaufbau: subst, muster.
  5453.       pushSTACK(STACK_1);
  5454.       pushSTACK(S(translate_pathname));
  5455.       fehler(error,
  5456.              DEUTSCH ? "~: Ersetzungsstⁿcke ~ passen nicht in ~." :
  5457.              ENGLISH ? "~: replacement pieces ~ do not fit into ~" :
  5458.              FRANCAIS ? "~ : Les piΦces ~ ne vont pas dans ~." :
  5459.              ""
  5460.             );
  5461.     }
  5462.  
  5463. LISPFUN(translate_pathname,3,0,norest,key,2, (kw(all),kw(merge)))
  5464. # (TRANSLATE-PATHNAME beispiel muster1 muster2 [:all] [:merge]), CLtL2 S. 624
  5465. # :all = T --> liefere eine Liste aller passenden Pathnames
  5466. # :all = NIL --> Error, falls mehr als ein Pathname pa▀t
  5467. # :merge = NIL --> letzten MERGE-PATHNAMES Schritt ⁿberspringen
  5468.   { # Stackaufbau: beispiel, muster1, muster2, all, merge.
  5469.     var reg3 boolean logical = FALSE; # Flag, ob beispiel und muster logische Pathnames sind
  5470.     var reg4 boolean logical2 = FALSE; # Flag, ob muster2 ein logischer Pathname ist
  5471.     STACK_4 = coerce_xpathname(STACK_4);
  5472.     STACK_3 = coerce_xpathname(STACK_3);
  5473.     STACK_2 = coerce_xpathname(STACK_2);
  5474.     #ifdef LOGICAL_PATHNAMES
  5475.     if (logpathnamep(STACK_4) && logpathnamep(STACK_3))
  5476.       { logical = TRUE; }
  5477.       else
  5478.       # nicht beides logische Pathnames -> erst in normale Pathnames umwandeln:
  5479.       { STACK_4 = coerce_pathname(STACK_4);
  5480.         STACK_3 = coerce_pathname(STACK_3);
  5481.       }
  5482.     if (logpathnamep(STACK_2))
  5483.       { logical2 = TRUE; }
  5484.     #endif
  5485.     # 1. Schritt: Liste aller passenden Substitutionen bilden.
  5486.     pushSTACK(NIL); pushSTACK(NIL);
  5487.     host_diff(xpathname_host(logical,STACK_(3+2)),xpathname_host(logical,STACK_(4+2)),logical,&STACK_1,&STACK_0);
  5488.     while (mconsp(STACK_0))
  5489.       { pushSTACK(Car(STACK_0)); pushSTACK(NIL);
  5490.         device_diff(xpathname_device(logical,STACK_(3+4)),xpathname_device(logical,STACK_(4+4)),logical,&STACK_1,&STACK_0);
  5491.         while (mconsp(STACK_0))
  5492.           { pushSTACK(Car(STACK_0)); pushSTACK(NIL);
  5493.             directory_diff(xpathname_directory(logical,STACK_(3+6)),xpathname_directory(logical,STACK_(4+6)),logical,&STACK_1,&STACK_0);
  5494.             while (mconsp(STACK_0))
  5495.               { pushSTACK(Car(STACK_0)); pushSTACK(NIL);
  5496.                 nametype_diff(xpathname_name(logical,STACK_(3+8)),xpathname_name(logical,STACK_(4+8)),logical,&STACK_1,&STACK_0);
  5497.                 while (mconsp(STACK_0))
  5498.                   { pushSTACK(Car(STACK_0)); pushSTACK(NIL);
  5499.                     nametype_diff(xpathname_type(logical,STACK_(3+10)),xpathname_type(logical,STACK_(4+10)),logical,&STACK_1,&STACK_0);
  5500.                     while (mconsp(STACK_0))
  5501.                       { pushSTACK(Car(STACK_0));
  5502.                         version_diff(xpathname_version(logical,STACK_(3+11)),xpathname_version(logical,STACK_(4+11)),logical,&STACK_0,&STACK_10);
  5503.                         skipSTACK(1);
  5504.                         STACK_0 = Cdr(STACK_0);
  5505.                       }
  5506.                     skipSTACK(2);
  5507.                     STACK_0 = Cdr(STACK_0);
  5508.                   }
  5509.                 skipSTACK(2);
  5510.                 STACK_0 = Cdr(STACK_0);
  5511.               }
  5512.             skipSTACK(2);
  5513.             STACK_0 = Cdr(STACK_0);
  5514.           }
  5515.         skipSTACK(2);
  5516.         STACK_0 = Cdr(STACK_0);
  5517.       }
  5518.     skipSTACK(1);
  5519.     # Stackaufbau: ..., solutions.
  5520.     if (matomp(STACK_0))
  5521.       { pushSTACK(STACK_(3+1));
  5522.         pushSTACK(STACK_(4+1+1));
  5523.         pushSTACK(S(translate_pathname));
  5524.         fehler(error,
  5525.                DEUTSCH ? "~: ~ ist keine Spezialisierung von ~." :
  5526.                ENGLISH ? "~: ~ is not a specialization of ~" :
  5527.                FRANCAIS ? "~ : ~ ne spΘcialise pas ~." :
  5528.                ""
  5529.               );
  5530.       }
  5531.     # 2.,3. Schritt:
  5532.     pushSTACK(NIL); # pathnames := '()
  5533.     while (mconsp(STACK_1)) # solutions durchgehen
  5534.       { var reg1 object solutions = STACK_1;
  5535.         STACK_1 = Cdr(solutions);
  5536.        {var reg2 object solution = reverse(Car(solutions)); # Liste solution umdrehen
  5537.         # 2. Schritt: Substitution in muster2 einfⁿgen.
  5538.         #ifdef LOGICAL_PATHNAMES
  5539.         # Gro▀-/Kleinschreibung passend konvertieren:
  5540.         if (!logical)
  5541.           { if (logical2)
  5542.               { solution = subst_logical_case(solution); }
  5543.           }
  5544.           else
  5545.           { if (!logical2)
  5546.               { solution = subst_customary_case(solution); }
  5547.           }
  5548.         #endif
  5549.         pushSTACK(solution);
  5550.         STACK_0 = translate_pathname(&STACK_0,STACK_(2+1+2));
  5551.        }
  5552.         # 3. Schritt: (MERGE-PATHNAMES modifiziertes_muster2 beispiel :WILD T)
  5553.         if (!nullp(STACK_(0+1+2))) # :MERGE-Argument abfragen
  5554.           if (has_some_wildcards(STACK_0)) # evtl. ist MERGE-PATHNAMES unn÷tig
  5555.             { pushSTACK(STACK_(4+1+2)); pushSTACK(unbound);
  5556.               pushSTACK(S(Kwild)); pushSTACK(T);
  5557.               funcall(L(merge_pathnames),5);
  5558.               pushSTACK(value1);
  5559.             }
  5560.         # (PUSH pathname pathnames)
  5561.        {var reg1 object new_cons = allocate_cons();
  5562.         Car(new_cons) = popSTACK(); Cdr(new_cons) = STACK_0;
  5563.         STACK_0 = new_cons;
  5564.       }}
  5565.     # 4. Schritt: (DELETE-DUPLICATES pathnames :TEST #'EQUAL)
  5566.     pushSTACK(S(Ktest)); pushSTACK(L(equal));
  5567.     funcall(L(delete_duplicates),3);
  5568.     # Stackaufbau: ..., nil.
  5569.     if (eq(STACK_(1+1),unbound) || nullp(STACK_(1+1))) # :ALL-Argument abfragen
  5570.       { if (mconsp(Cdr(value1)))
  5571.           { pushSTACK(value1);
  5572.             pushSTACK(STACK_(2+2));
  5573.             pushSTACK(STACK_(3+3));
  5574.             pushSTACK(STACK_(4+4));
  5575.             pushSTACK(S(translate_pathname));
  5576.             fehler(error,
  5577.                    DEUTSCH ? "(~ ~ ~ ~) ist nicht eindeutig: ~" :
  5578.                    ENGLISH ? "(~ ~ ~ ~) is ambiguous: ~" :
  5579.                    FRANCAIS ? "(~ ~ ~ ~) est ambigu: ~" :
  5580.                    ""
  5581.                   );
  5582.           }
  5583.         value1 = Car(value1);
  5584.       }
  5585.     mv_count=1;
  5586.     skipSTACK(5+1);
  5587.   }
  5588.  
  5589. # UP: Stellt fest, ob der Name eines Pathname =NIL ist.
  5590. # namenullp(pathname)
  5591. # > pathname: nicht-Logical Pathname
  5592.   # local boolean namenullp (object pathname);
  5593.   # local boolean namenullp(pathname)
  5594.   #   { return nullp(ThePathname(pathname)->pathname_name); }
  5595.   #define namenullp(path)  (nullp(ThePathname(path)->pathname_name))
  5596.  
  5597. # Fehler, wenn ein Directory nicht existiert
  5598. # > obj: Pathname oder (besser) fehlerhafte Komponente
  5599.   nonreturning_function(local, fehler_dir_not_exists, (object obj));
  5600.   local void fehler_dir_not_exists(obj)
  5601.     var reg1 object obj;
  5602.     { pushSTACK(obj); # Wert fⁿr Slot PATHNAME von FILE-ERROR
  5603.       pushSTACK(obj);
  5604.       fehler(file_error,
  5605.              DEUTSCH ? "Directory existiert nicht: ~" :
  5606.              ENGLISH ? "nonexistent directory: ~" :
  5607.              FRANCAIS ? "Le rΘpertoire ~ n'existe pas." :
  5608.              ""
  5609.             );
  5610.     }
  5611.  
  5612. # Fehler, wenn eine Datei bereits existiert
  5613. # > caller: Aufrufer (ein Symbol)
  5614. # > pathname: Pathname
  5615.   nonreturning_function(local, fehler_file_exists, (object caller, object pathname));
  5616.   local void fehler_file_exists(caller,pathname)
  5617.     var reg2 object caller;
  5618.     var reg1 object pathname;
  5619.     { pushSTACK(pathname); # Wert fⁿr Slot PATHNAME von FILE-ERROR
  5620.       pushSTACK(pathname);
  5621.       pushSTACK(caller);
  5622.       fehler(file_error,
  5623.              DEUTSCH ? "~: Eine Datei ~ existiert bereits." :
  5624.              ENGLISH ? "~: File ~ already exists" :
  5625.              FRANCAIS ? "~ : Le fichier ~ existe dΘjα." :
  5626.              ""
  5627.             );
  5628.     }
  5629.  
  5630. #ifdef LOGICAL_PATHNAMES
  5631. # Ein "absoluter Pathname" ist stets ein nicht-Logical Pathname, evtl.
  5632. # mit weiteren EinschrΣnkungen.
  5633. #endif
  5634.  
  5635. #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  5636.  
  5637. #ifdef PATHNAME_ATARI
  5638. # Ein "absoluter Pathname" ist ein Pathname, bei dem Device ein ⁿberprⁿfter
  5639. # String ist und Directory die Seriennummer, aber kein :RELATIVE, :CURRENT,
  5640. # :PARENT enthΣlt.
  5641. #endif
  5642. #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  5643. # Ein "absoluter Pathname" ist ein Pathname, bei dem Device ein ⁿberprⁿfter
  5644. # String ist und Directory kein :RELATIVE, :CURRENT, :PARENT enthΣlt.
  5645. #endif
  5646.  
  5647. # UP: Liefert den Namestring eines Pathname als ASCIZ-String.
  5648. # namestring_asciz(dir_namestring)
  5649. # > STACK_0: nicht-Logical Pathname
  5650. # > dir_namestring: Directory-Namestring (fⁿr DOS bzw. GEMDOS, ohne Seriennummer)
  5651. # < ergebnis: Namestring (fⁿr DOS bzw. GEMDOS, ohne Seriennummer, mit Nullbyte am Schlu▀)
  5652. # kann GC ausl÷sen
  5653.   local object namestring_asciz (object dir_namestring);
  5654.   local object namestring_asciz(dir_namestring)
  5655.     var reg2 object dir_namestring;
  5656.     { var reg1 uintC stringcount;
  5657.       pushSTACK(dir_namestring); # Directory-Namestring als 1. String
  5658.       stringcount = file_namestring_parts(STACK_(0+1)); # Strings zum Filenamen
  5659.       pushSTACK(O(null_string)); # String mit Nullbyte
  5660.       return string_concat(1+stringcount+1); # zusammenhΣngen
  5661.     }
  5662.  
  5663. #ifdef PATHNAME_ATARI
  5664.  
  5665. #if HAS_SERNR && defined(ATARI)
  5666. # UP: Holt die Seriennummer einer Diskette.
  5667. # get_disk_number(drive)
  5668. # > uintW drive : Laufwerksbuchstabe ('A', 'B', ...)
  5669. # < object ergebnis : Seriennummer als Fixnum >=0
  5670. # kann GC ausl÷sen
  5671.   local object get_disk_number (uintW drive);
  5672.   local uintB volume_path[] = "?:\\*.*";
  5673.   local DTA dta_buf;
  5674.   local object get_disk_number(drive)
  5675.     var reg2 uintW drive;
  5676.     # Methode:
  5677.     # Damit GEMDOS einen eventuellen Diskettenwechsel erkennt (und dann seine
  5678.     # internen Buffer leert, so da▀ korrekter Zugriff auf die Unterdirectories
  5679.     # m÷glich wird), darf GEMDOS vor dem BIOS die Diskette ansehen. Dazu darf
  5680.     # es erst einmal das Volume-Label suchen.
  5681.     # Danach holen wir uns mit einem BIOS-Zugriff die Seriennummer.
  5682.     { var reg3 uintL sectorlength;
  5683.       volume_path[0] = (uintB)drive; # Pfad fⁿr Volume-Label-Suche 'X:\*.*'
  5684.                               # mit korrektem Laufwerksbuchstaben versehen
  5685.       GEMDOS_SetDTA(&dta_buf); # DTA-Buffer setzen
  5686.       { var reg1 WORD erg = GEMDOS_Sfirst(&volume_path,8); # Suche des Volume-Label beginnen
  5687.                                # (8 = Attributmaske fⁿr "nur Volume-Label suchen")
  5688.         if (!(erg == GEMDOS_Sfirst_notfound) && (erg<0))
  5689.           OS_error(erg); # wesentlicher Fehler aufgetreten -> melden
  5690.       }
  5691.       # Volume-Label ist OK.
  5692.       drive = drive - 'A'; # drive = Laufwerksnummer
  5693.       { var reg1 BPB* erg = BIOS_GetBPB(drive); # Disk-Parameter holen
  5694.         if (erg==(BPB*)0) # Fehler?
  5695.           OS_error(-1); # ja -> erzeuge Fehler 'Allgemeiner Fehler'
  5696.         sectorlength = (uintL)(erg->recsiz);
  5697.       }
  5698.       # sectorlength = LΣnge (in Bytes) der Sectoren auf dieser Diskette
  5699.       { var DYNAMIC_ARRAY(reg4,bootsector,BYTE,sectorlength);
  5700.         # Bootsector lesen:
  5701.         { var reg1 WORD erg = BIOS_ReadAbs(bootsector,1,0,drive); # 1 Sector ab Sector 0 lesen
  5702.           if (erg<0) # Fehler aufgetreten -> melden
  5703.             { FREE_DYNAMIC_ARRAY(bootsector); OS_error(erg); }
  5704.         }
  5705.         # Bytes 8,9,10 ist die Disknummer:
  5706.         { var reg1 uintL seriennummer = *(ULONG*)(bootsector+8) >> 8;
  5707.           FREE_DYNAMIC_ARRAY(bootsector);
  5708.           return(fixnum(seriennummer)); # als Fixnum
  5709.     } } }
  5710. #endif
  5711.  
  5712. # UP: Bestimmt den Alisteneintrag in DRIVE_ALIST zu einem gegebenen Drive.
  5713. # get_drive_alist(pathname)
  5714. # > pathname: Pathname mit String als Device
  5715. # < ergebnis: Alisteneintrag
  5716.   local object get_drive_alist (object pathname);
  5717.   local object get_drive_alist(pathname)
  5718.     var reg5 object pathname;
  5719.     { var reg4 object device = ThePathname(pathname)->pathname_device;
  5720.       var reg3 uintB drive = TheSstring(device)->data[0]; # Laufwerksbuchstabe
  5721.       # Drive-Aliste durchlaufen:
  5722.       var reg2 object alistr = O(drive_alist);
  5723.       while (consp(alistr))
  5724.         { var reg1 object entry = Car(alistr); # Alisteneintrag
  5725.           # (car entry) ist ein Simple-String der LΣnge 1. Mit drive vergleichen:
  5726.           if (TheSstring(Car(entry))->data[0] == drive) { return entry; }
  5727.           alistr = Cdr(alistr);
  5728.         }
  5729.       # Liste zu Ende -> nicht existentes Laufwerk
  5730.       pushSTACK(pathname); # Wert fⁿr Slot PATHNAME von FILE-ERROR
  5731.       pushSTACK(device);
  5732.       fehler(file_error,
  5733.              DEUTSCH ? "Ein Laufwerk ~ gibt es nicht." :
  5734.              ENGLISH ? "drive ~ does not exist" :
  5735.              FRANCAIS ? "Le disque ~ n'existe pas." :
  5736.              ""
  5737.             );
  5738.     }
  5739.  
  5740. #endif
  5741.  
  5742. #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  5743.  
  5744. #if !(defined(WATCOM) && defined(WINDOWS))
  5745.  
  5746. # Working Directory auf einem gegebenen Drive abfragen:
  5747. # getwdof(&buf,drive)
  5748. # > uintB* &buf: Adresse eines Path-Buffers
  5749. # > uintB drive: Laufwerk (0=A, 1=B, ...)
  5750. # < ergebnis: <0 falls Fehler
  5751.   #ifdef DJUNIX
  5752.     #define getwdof(buf,drive)  \
  5753.       ({__asm__ (# DOS Function 47H                                                         \
  5754.                  " movb $0x47,%%ah ; int $0x21 "                                            \
  5755.                  :                                                                # OUT     \
  5756.                  : "S" /* %esi */ ((uintB*)(buf)), "d" /* %dl */ ((uintB)(drive)) # IN      \
  5757.                  : "ax","bx","cx","di" /* %eax, %ebx, %ecx, %edi */               # CLOBBER \
  5758.                 );                                                                          \
  5759.         0;                                                                                  \
  5760.        })
  5761.   #endif
  5762.   #ifdef EMUNIX
  5763.     #define getwdof(buf,drive)  _getcwd(buf,drive)
  5764.   #endif
  5765.   #ifdef WATCOM
  5766.     local int getwdof (uintB* buf, uintB drive);
  5767.     local int getwdof(buf,drive)
  5768.       var uintB* buf;
  5769.       var uintB drive;
  5770.       { var union REGS in;
  5771.         var union REGS out;
  5772.         in.regB.ah = 0x47; in.regB.dl = drive; in.regL.esi = (unsigned long) buf;
  5773.         intdos(&in,&out);
  5774.         return 0;
  5775.       }
  5776.   #endif
  5777.  
  5778. # Liefert das aktuelle Directory auf einem Laufwerk.
  5779. # getwd_of(path,drive)
  5780. # > uintB drive: Laufwerks-(gro▀-)buchstabe
  5781. # > uintB* path: Platz fⁿrs aktuelle Directory
  5782. # < path: Pfad des aktuellen Directories, mit '/' als Trennzeichen und als Anfang
  5783. # < ergebnis: <0 falls Fehler
  5784.   #if defined(DJUNIX) || defined(WATCOM)
  5785.     #define getwd_of(path,drive)  ((path)[0] = '/', getwdof(&(path)[1],(drive)-'A'+1))
  5786.   #endif
  5787.   #ifdef EMUNIX
  5788.     #define getwd_of(path,drive)  _getcwd1(path,drive)
  5789.   #endif
  5790.  
  5791. #endif # !(WATCOM && WINDOWS)
  5792.  
  5793. # UP: Stellt fest, ob ein Laufwerk existiert.
  5794. # > uintB drive: Laufwerks-(gro▀-)buchstabe
  5795. # < boolean ergebnis: ob dieses Laufwerk existiert und ansprechbar ist
  5796.   local boolean good_drive (uintB drive);
  5797.   #ifdef EMUNIX
  5798.   local boolean good_drive(drive)
  5799.     var reg1 uintB drive;
  5800.     { # Methode (siehe HELPPC/misc.txt):
  5801.       # 1. save current drive  (INT 0x21,0x19)
  5802.       # 2. set current drive  (INT 0x21,0xE)
  5803.       # 3. get current drive  (INT 0x21,0x19)
  5804.       # 4. if current drive == drive requested
  5805.       #       then drive exists
  5806.       #       else drive doesn't exist
  5807.       # 5. reset original drive  (INT 0x21,0xE)
  5808.       var reg3 boolean result;
  5809.       begin_system_call();
  5810.      {var reg2 uintB orig_drive = _getdrive();
  5811.       _chdrive(drive);
  5812.       result = (_getdrive() == drive);
  5813.       _chdrive(orig_drive);
  5814.      }
  5815.       end_system_call();
  5816.       return result;
  5817.       # Alternative:
  5818.       # { var uintB drv[3];
  5819.       #   var uintB fsys[16];
  5820.       #   drv[0] = drive; drv[1] = ':'; drv[2] = '\0';
  5821.       #   begin_system_call();
  5822.       #  {var int result = _filesys(drv,&fsys,sizeof(fsys));
  5823.       #   end_system_call();
  5824.       #   return (result==0);
  5825.       # }}
  5826.     }
  5827.   #endif
  5828.   #if defined(DJUNIX) || defined(WATCOM)
  5829.   local boolean good_drive(drive)
  5830.     var reg1 uintB drive;
  5831.     { # Methode (siehe HELPPC/misc.txt):
  5832.       # 1. save current drive  (INT 0x21,0x19)
  5833.       # 2. set current drive  (INT 0x21,0xE)
  5834.       # 3. get current drive  (INT 0x21,0x19)
  5835.       # 4. if current drive == drive requested
  5836.       #       then drive exists
  5837.       #       else drive doesn't exist
  5838.       # 5. reset original drive  (INT 0x21,0xE)
  5839.       var union REGS in;
  5840.       var union REGS out;
  5841.       var reg2 uintB orig_drive;
  5842.       var reg3 boolean result;
  5843.       begin_system_call();
  5844.       in.regB.ah = 0x19; intdos(&in,&out); orig_drive = out.regB.al; # 1.
  5845.       in.regB.ah = 0x0E; in.regB.dl = drive; intdos(&in,&out);       # 2.
  5846.       in.regB.ah = 0x19; intdos(&in,&out);                           # 3.
  5847.       result = (out.regB.al == drive);                               # 4.
  5848.       in.regB.ah = 0x0E; in.regB.dl = orig_drive; intdos(&in,&out);  # 5.
  5849.       end_system_call();
  5850.       return result;
  5851.     }
  5852.   #endif
  5853.  
  5854. # UP: Liefert das aktuelle Drive.
  5855. # < uintB drive: Laufwerks-(gro▀-)buchstabe
  5856.   local uintB default_drive (void);
  5857.  #ifdef EMUNIX
  5858.   local uintB default_drive()
  5859.     { var reg1 uintB result;
  5860.       begin_system_call();
  5861.       result = _getdrive();
  5862.       end_system_call();
  5863.       return result;
  5864.     }
  5865.  #endif
  5866.  #if defined(DJUNIX) || defined(WATCOM)
  5867.   #if 1
  5868.     local uintB default_drive()
  5869.       { var union REGS in;
  5870.         var union REGS out;
  5871.         begin_system_call();
  5872.         in.regB.ah = 0x19;
  5873.         intdos(&in,&out);
  5874.         end_system_call();
  5875.         return 'A'+out.regB.al;
  5876.       }
  5877.   #else # nur defined(WATCOM)
  5878.     local uintB default_drive()
  5879.       { var unsigned int drive;
  5880.         begin_system_call();
  5881.         _dos_getdrive(&drive);
  5882.         end_system_call();
  5883.         return 'A'+drive-1;
  5884.       }
  5885.   #endif
  5886.  #endif
  5887.  
  5888. # UP: Liefert das aktuelle Directory auf einem gegebenen Drive.
  5889. # > uintB drive: Laufwerks-(gro▀-)buchstabe
  5890. # < ergebnis: aktuelles Directory (als Pathname)
  5891. # kann GC ausl÷sen
  5892.   local object default_directory_of (uintB drive);
  5893.   local object default_directory_of(drive)
  5894.     var reg1 uintB drive;
  5895.     # Working Directory (von DOS) ist das aktuelle Directory:
  5896.     { var char path_buffer[3+MAXPATHLEN]; # vgl. GETWD(3)
  5897.       #if !(defined(WATCOM) && defined(WINDOWS))
  5898.         path_buffer[0] = drive; path_buffer[1] = ':';
  5899.         # Working Directory in path_buffer ablegen:
  5900.         begin_system_call();
  5901.         getwd_of(&path_buffer[2],drive);
  5902.         end_system_call();
  5903.       #else # defined(WATCOM) && defined(WINDOWS)
  5904.         # Methode:
  5905.         # 1. save current drive  (INT 0x21,0x19)
  5906.         # 2. set current drive  (INT 0x21,0xE)
  5907.         # 3. get current directory on current drive  (getcwd)
  5908.         # 4. reset original drive  (INT 0x21,0xE)
  5909.         { var union REGS in;
  5910.           var union REGS out;
  5911.           var reg2 uintB orig_drive;
  5912.           begin_system_call();
  5913.           in.regB.ah = 0x19; intdos(&in,&out); orig_drive = out.regB.al; # 1.
  5914.           in.regB.ah = 0x0E; in.regB.dl = drive-'A'+1; intdos(&in,&out); # 2.
  5915.           getcwd(&path_buffer[0],sizeof(path_buffer));                   # 3.
  5916.           in.regB.ah = 0x0E; in.regB.dl = orig_drive; intdos(&in,&out);  # 4.
  5917.           end_system_call();
  5918.         }
  5919.         ASSERT(path_buffer[0]==drive);
  5920.         ASSERT(path_buffer[1]==':');
  5921.         ASSERT(path_buffer[2]=='\\');
  5922.         # evtl. noch ein '\' am Schlu▀ anfⁿgen:
  5923.         { var reg2 char* path_end = &path_buffer[asciz_length(path_buffer)];
  5924.           if (!(path_end[-1]=='\\')) { path_end[0] = '\\'; path_end[1] = '\0'; }
  5925.         }
  5926.       #endif
  5927.       # Hack von DJ (siehe GO32/EXPHDLR.C) und EM (siehe LIB/MISC/_GETCWD1.C):
  5928.       # wandelt alle '\' in '/' und alle Gro▀- in Kleinbuchstaben (nur Kosmetik,
  5929.       # da DOS und unser PARSE-NAMESTRING auch Filenamen mit '/' statt '\'
  5930.       # verstehen).
  5931.       # in Pathname umwandeln:
  5932.       return asciz_dir_to_pathname(&path_buffer[0]);
  5933.     }
  5934.  
  5935. #endif
  5936.  
  5937. # UP: Fⁿllt Default-Drive und Default-Directory in einen Pathname ein.
  5938. # use_default_dir(pathname)
  5939. # > pathname: nicht-Logical Pathname mit Device /= :WILD
  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 reg4 object pathname;
  5945.     { # erst den Pathname kopieren:
  5946.       pathname = copy_pathname(pathname);
  5947.       pushSTACK(pathname);
  5948.       # Stackaufbau: pathname.
  5949.      #ifdef PATHNAME_ATARI
  5950.       # Bestimme das betreffende Laufwerk und die Seriennummer der
  5951.       # darin eingelegten Diskette, und prⁿfe, ob sie mit der Seriennummer
  5952.       # im Pathname zusammenpa▀t:
  5953.      {var reg5 object disk_seriennummer; # Seriennummer der im Laufwerk drive
  5954.                                          # gerade eingelegten Diskette.
  5955.       retry_disk:
  5956.       pathname = STACK_0;
  5957.       # evtl. das Default-Drive nehmen:
  5958.       if (nullp(ThePathname(pathname)->pathname_device))
  5959.         { ThePathname(pathname)->pathname_device = O(default_drive); }
  5960.       { # Laufwerksbuchstaben holen:
  5961.         var reg7 uintB drive = TheSstring(ThePathname(pathname)->pathname_device)->data[0];
  5962.         # Alisteneintrag zum Drive holen:
  5963.         pushSTACK(get_drive_alist(pathname));
  5964.         # Stackaufbau: pathname, Alisteneintrag.
  5965.         # Dann die Seriennummer der eingelegten Diskette holen:
  5966.         disk_seriennummer = get_disk_number(drive);
  5967.         # Dann die Seriennummern vergleichen:
  5968.        {var reg1 object path_seriennummer = Car(ThePathname(pathname=STACK_1)->pathname_directory);
  5969.         # path_seriennummer = in Pathname verlangte Seriennummer
  5970.         if (!(nullp(path_seriennummer) # keine verlangt ?
  5971.               || (eq(path_seriennummer,disk_seriennummer)) # oder beide gleich ?
  5972.            ) )
  5973.           { # Nein: Die verlangte Diskette ist nicht die eingelegte Diskette.
  5974.             # -> Continuable Error liefern:
  5975.             skipSTACK(1); # Alisteneintrag vergessen
  5976.             # (CERROR "Es geht weiter." "Legen Sie bitte die Diskette mit der Nummer ~D in Laufwerk ~A." Seriennummer Laufwerk)
  5977.             pushSTACK(OL(otherdisk_string1)); # "Es geht weiter."
  5978.             pushSTACK(OL(otherdisk_string2)); # "Legen Sie bitte die Diskette mit der Nummer ~D in Laufwerk ~A."
  5979.             pushSTACK(path_seriennummer); # Seriennummer
  5980.             pushSTACK(ThePathname(pathname)->pathname_device); # Laufwerk als String
  5981.             funcall(S(cerror),4);
  5982.             # und erneut versuchen:
  5983.             goto retry_disk;
  5984.       }}  }
  5985.       # Stackaufbau: pathname, Alisteneintrag.
  5986.       # Dann das Default-Directory zu dieser Seriennummer bestimmen:
  5987.       { var reg6 object default_dir; # Default-Directory (ein Pathname)
  5988.         {var reg1 object alistr = STACK_0; # Alisteneintrag durchlaufen
  5989.          while (consp(alistr=Cdr(alistr)))
  5990.            { var reg1 object entry = Car(alistr);
  5991.              if (eq(Car(entry),disk_seriennummer))
  5992.                { default_dir = Cdr(entry); goto default_dir_ok; }
  5993.         }  }
  5994.         # Bisher (auf diesem Drive) unbekannte Diskette.
  5995.         # Default-Directory := '\' :
  5996.         {var reg1 object new_cons = allocate_cons(); # Neues Cons
  5997.          Car(new_cons) = disk_seriennummer; # (cons seriennummer nil)
  5998.          pushSTACK(new_cons); # retten
  5999.          default_dir = allocate_pathname(); # neuer Pathname mit Name=NIL und Typ=NIL
  6000.          ThePathname(default_dir)->pathname_directory = popSTACK(); # mit Directory (cons seriennummer nil)
  6001.          ThePathname(default_dir)->pathname_device = ThePathname(STACK_1)->pathname_device;
  6002.          pushSTACK(default_dir); # retten
  6003.          new_cons = allocate_cons(); # neues Cons
  6004.          Car(new_cons) = disk_seriennummer; Cdr(new_cons) = STACK_0;
  6005.          pushSTACK(new_cons); # (cons seriennummer default_dir) retten
  6006.          new_cons = allocate_cons(); # neues Cons
  6007.          Car(new_cons) = popSTACK();
  6008.          # new_cons = (list (cons seriennummer default_dir))
  6009.          default_dir = popSTACK();
  6010.          # Alisteneintrag um die 1-elementige Liste new_cons erweitern:
  6011.          Cdr(new_cons) = Cdr(STACK_0); Cdr(STACK_0) = new_cons;
  6012.         }
  6013.         default_dir_ok:
  6014.         skipSTACK(1); # Alisteneintrag vergessen
  6015.         # Stackaufbau: pathname.
  6016.         # default_dir (ein Pathname) und disk_seriennummer (ein Fixnum) sind fertig.
  6017.         # Dann das Default-Directory in den Pathname einbauen:
  6018.         { var reg3 object subdirs = Cdr(ThePathname(STACK_0)->pathname_directory);
  6019.           # FΣngt (CDR pathname-directory) mit :RELATIVE an?
  6020.           if (eq(Car(subdirs),S(Krelative)))
  6021.             { # ja -> Ersetze :RELATIVE durch default-subdirs, d.h.
  6022.               # bilde  (append default-subdirs (cdr subdirs))
  6023.               #      = (nreconc (reverse default-subdirs) (cdr subdirs))
  6024.               pushSTACK(Cdr(subdirs));
  6025.              {var reg1 object temp = Cdr(ThePathname(default_dir)->pathname_directory);
  6026.               temp = reverse(temp);
  6027.               subdirs = nreconc(temp,popSTACK());
  6028.             }}
  6029.      #endif
  6030.      #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  6031.       # Default fⁿrs Device:
  6032.       if (nullp(ThePathname(pathname)->pathname_device)) # kein Device angegeben?
  6033.         # Nimm das Default-Drive stattdessen:
  6034.         { ThePathname(pathname)->pathname_device = O(default_drive); }
  6035.       # Default fⁿrs Directory:
  6036.         { var reg3 object subdirs = ThePathname(pathname)->pathname_directory;
  6037.           # FΣngt pathname-directory mit :RELATIVE an?
  6038.           if (eq(Car(subdirs),S(Krelative)))
  6039.             # ja -> Ersetze :RELATIVE durch das Default-Directory:
  6040.             { var reg5 uintB drive = TheSstring(ThePathname(pathname)->pathname_device)->data[0];
  6041.               var reg2 object default_dir = default_directory_of(drive);
  6042.               # default_dir (ein Pathname) ist fertig.
  6043.               # Ersetze :RELATIVE durch default-subdirs, d.h.
  6044.               # bilde  (append default-subdirs (cdr subdirs))
  6045.               #      = (nreconc (reverse default-subdirs) (cdr subdirs))
  6046.               pushSTACK(Cdr(subdirs));
  6047.              {var reg1 object temp = ThePathname(default_dir)->pathname_directory;
  6048.               temp = reverse(temp);
  6049.               subdirs = nreconc(temp,popSTACK());
  6050.             }}
  6051.      #endif
  6052.           # Liste durchgehen und dabei neu aufconsen, dabei '.\' und '..\'
  6053.           # und '...\' verarbeiten (nicht dem DOS bzw. GEMDOS ⁿberlassen):
  6054.           pushSTACK(subdirs);
  6055.           pushSTACK(NIL);
  6056.           # Stackaufbau: Pathname, subdir-oldlist, subdir-newlist.
  6057.           while (mconsp(STACK_1)) # Bis oldlist am Ende ist:
  6058.             { var reg2 object subdir = Car(STACK_1); # nΣchstes subdir
  6059.               if
  6060.                  #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS)
  6061.                  (eq(subdir,S(Kcurrent)))
  6062.                  #else
  6063.                  (equal(subdir,O(punkt_string)))
  6064.                  #endif
  6065.                 # = :CURRENT -> newlist unverΣndert lassen
  6066.                 {}
  6067.               elif
  6068.                    #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS)
  6069.                    (eq(subdir,S(Kparent)))
  6070.                    #else
  6071.                    (equal(subdir,O(punktpunkt_string)))
  6072.                    #endif
  6073.                 # = :PARENT -> newlist um eins verkⁿrzen:
  6074.                 { if (matomp(Cdr(STACK_0))) # newlist (bis auf :ABSOLUTE) leer ?
  6075.                     { # :PARENT von "\" aus liefert Error
  6076.                       pushSTACK(STACK_2); # Wert fⁿr Slot PATHNAME von FILE-ERROR
  6077.                       pushSTACK(O(backslash_string)); # "\\"
  6078.                       pushSTACK(directory_namestring(STACK_(2+2))); # Directory von pathname
  6079.                       fehler(file_error,
  6080.                              DEUTSCH ? "Directory ~ oberhalb ~ existiert nicht." :
  6081.                              ENGLISH ? "no directory ~ above ~" :
  6082.                              FRANCAIS ? "Il n'y a pas de rΘpertoire ~ au delα de ~." :
  6083.                              ""
  6084.                             );
  6085.                     }
  6086.                   if (eq(Car(STACK_0),S(Kwild_inferiors))) # newlist fΣngt mit '...\' an ?
  6087.                     { # :PARENT von "...\" aus liefert Error
  6088.                       pushSTACK(STACK_2); # Wert fⁿr Slot PATHNAME von FILE-ERROR
  6089.                       pushSTACK(directory_namestring(STACK_(2+1))); # Directory von pathname
  6090.                       fehler(file_error, # '"..\\" nach "...\\" ist unzulΣssig: ~'
  6091.                              DEUTSCH ? "\"..\\\\\" nach \"...\\\\\" ist unzulΣssig: ~" :
  6092.                              ENGLISH ? "\"..\\\\\" after \"...\\\\\" is invalid: ~" :
  6093.                              FRANCAIS ? "\"..\\\\\" aprΦs \"...\\\\\" n'est pas permis : ~" :
  6094.                              ""
  6095.                             );
  6096.                     }
  6097.                   STACK_0 = Cdr(STACK_0);
  6098.                 }
  6099.               else # (auch wenn :ABSOLUTE !)
  6100.                 { # newlist um eins verlΣngern:
  6101.                   pushSTACK(subdir);
  6102.                  {var reg1 object new_cons = allocate_cons();
  6103.                   Car(new_cons) = popSTACK();
  6104.                   Cdr(new_cons) = STACK_0;
  6105.                   STACK_0 = new_cons;
  6106.                 }}
  6107.               STACK_1 = Cdr(STACK_1);
  6108.             }
  6109.           subdirs = nreverse(popSTACK()); # newlist, wieder umdrehen
  6110.      #ifdef PATHNAME_ATARI
  6111.           STACK_0 = subdirs; # und retten
  6112.       } }
  6113.       # Stackaufbau: pathname, subdirs.
  6114.       {var reg1 object new_cons = allocate_cons(); # neues Cons
  6115.        Car(new_cons) = disk_seriennummer; Cdr(new_cons) = popSTACK();
  6116.        # new_cons = (cons disk_seriennummer subdirs)
  6117.        # in den Pathname eintragen:
  6118.        pathname = popSTACK();
  6119.        ThePathname(pathname)->pathname_directory = new_cons;
  6120.      }}
  6121.      #endif
  6122.      #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  6123.           skipSTACK(1);
  6124.           # Stackaufbau: pathname.
  6125.           pathname = popSTACK();
  6126.           ThePathname(pathname)->pathname_directory = subdirs; # in den Pathname eintragen
  6127.         }
  6128.      #endif
  6129.       return pathname;
  6130.     }
  6131.  
  6132. #ifdef PATHNAME_ATARI
  6133.  
  6134. # UP: Stellt sicher, da▀ das Directory eines Pathname existiert.
  6135. # Sonst Fehlermeldung.
  6136. # Grund:
  6137. #   GEMDOS ist dazu nach Diskettenwechsel nicht in der Lage und interpretiert
  6138. #   manchmal (nach Diskettenwechsel) beliegige Dateiinhalte als Directories.
  6139. #   Daher mⁿssen wir GEMDOS auf die Sprⁿnge helfen und bei jedem Unter-
  6140. #   Directory selber testen, ob es existiert.
  6141. # assure_dir_exists(tolerantp)
  6142. # > STACK_0: absoluter Pathname ohne Wildcards im Directory
  6143. # > tolerantp: Flag, ob ein Fehler vermieden werden soll
  6144. # < ergebnis:
  6145. #     falls Name=NIL: Directory-Namestring (fⁿr GEMDOS, ohne Seriennummer)
  6146. #     falls Name/=NIL: Namestring (fⁿr GEMDOS, ohne Seriennummer, mit Nullbyte am Schlu▀)
  6147. #     falls tolerantp evtl.: nullobj
  6148. # kann GC ausl÷sen
  6149.   local object assure_dir_exists (boolean tolerantp);
  6150.   local object assure_dir_exists(tolerantp)
  6151.     var reg3 boolean tolerantp;
  6152.     { {var reg1 object pathname = STACK_0;
  6153.        pushSTACK(Cdr(ThePathname(pathname)->pathname_directory)); # subdir-list (ohne Seriennummer)
  6154.        {pushSTACK(ThePathname(pathname)->pathname_device); # Device
  6155.         pushSTACK(O(doppelpunkt_string)); # ":"
  6156.         pushSTACK(O(backslash_string)); # "\\"
  6157.         pushSTACK(string_concat(3)); # zusammenhΣngen
  6158.       }}
  6159.       # Stackaufbau: Pathname, verlΣngerte subdir-list, Directory-Namestring.
  6160.       while (consp(STACK_1=Cdr(STACK_1)))
  6161.         { # Unterdirectory-Namestring aufbauen:
  6162.           {# (Erster String bereits in STACK_0, weitere zum subdir folgen:)
  6163.            var reg1 uintC stringcount = 1 + subdir_namestring_parts(STACK_1);
  6164.            pushSTACK(string_concat(stringcount));
  6165.           }
  6166.           {# in ASCIZ-String umwandeln:
  6167.            var reg2 uintB* asciz = TheAsciz(string_to_asciz(STACK_0));
  6168.            # Dateisuche gemΣ▀ GEMDOS-Konvention:
  6169.            var reg1 sintW errorcode;
  6170.            set_break_sem_4(); # wegen DTA-Buffer gegen Unterbrechungen sperren
  6171.            GEMDOS_SetDTA(&DTA_buffer); # DTA-Buffer setzen
  6172.            errorcode =
  6173.              GEMDOS_Sfirst(asciz,0x10); # Suchanfang, die Maske 0x10 sucht
  6174.                                         # nach Ordnern und normalen Dateien.
  6175.            if (errorcode == GEMDOS_Sfirst_notfound) # 'Keine Datei gefunden' ?
  6176.              goto not_exists;
  6177.            if (errorcode < 0) { OS_error(errorcode); } # sonstigen Error melden
  6178.            if (!(DTA_buffer.d_attrib & 0x10)) # gefundene Datei kein Unterdirectory ?
  6179.              { not_exists:
  6180.                clr_break_sem_4();
  6181.                if (tolerantp) { skipSTACK(2); return nullobj; }
  6182.                fehler_dir_not_exists(STACK_2);
  6183.              }
  6184.            clr_break_sem_4();
  6185.           }
  6186.           # Directory-Namestring zu Ende aufbauen:
  6187.           pushSTACK(O(backslash_string)); # "\\" an STACK_0 anhΣngen
  6188.           pushSTACK(string_concat(2));
  6189.         }
  6190.       {var reg1 object dir_namestring = popSTACK(); # Directory-Namestring
  6191.        skipSTACK(1);
  6192.        if (namenullp(STACK_0))
  6193.          { return dir_namestring; }
  6194.          else
  6195.          { return namestring_asciz(dir_namestring); }
  6196.     } }
  6197.  
  6198. #endif
  6199.  
  6200. #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  6201.  
  6202. # UP: Stellt sicher, da▀ das Directory eines Pathname existiert.
  6203. # Sonst Fehlermeldung.
  6204. # assure_dir_exists(tolerantp)
  6205. # > STACK_0: absoluter Pathname ohne Wildcards im Directory
  6206. # > tolerantp: Flag, ob ein Fehler vermieden werden soll
  6207. # < ergebnis:
  6208. #     falls Name=NIL: Directory-Namestring (fⁿr DOS)
  6209. #     falls Name/=NIL: Namestring (fⁿr DOS, mit Nullbyte am Schlu▀)
  6210. #     falls tolerantp evtl.: nullobj
  6211. # kann GC ausl÷sen
  6212.   local object assure_dir_exists (boolean tolerantp);
  6213.   local object assure_dir_exists(tolerantp)
  6214.     var reg4 boolean tolerantp;
  6215.     { var reg2 uintC stringcount = directory_namestring_parts(STACK_0); # Strings fⁿrs Directory
  6216.       var reg1 object dir_namestring = string_concat(stringcount); # zusammenhΣngen
  6217.       # Existenztest:
  6218.       if (!nullp(Cdr(ThePathname(STACK_0)->pathname_directory))) # Subdir-List leer -> OK
  6219.         # (Mu▀ abgefangen werden, denn stat() auf Rootdir liefert Fehler.)
  6220.         {var struct stat statbuf;
  6221.          var reg3 uintB* endptr = &TheSstring(dir_namestring)->data[TheSstring(dir_namestring)->length-1];
  6222.          *endptr = '\0'; # '\' am Schlu▀ durch Nullbyte ersetzen
  6223.          begin_system_call();
  6224.          if (stat(TheAsciz(dir_namestring),&statbuf) < 0)
  6225.            { end_system_call();
  6226.              if (tolerantp && (errno==ENOENT)) { return nullobj; }
  6227.              OS_error();
  6228.            }
  6229.          end_system_call();
  6230.          *endptr = '\\'; # wieder mit '\' abschlie▀en
  6231.          if (!S_ISDIR(statbuf.st_mode)) # gefundene Datei kein Unterdirectory ?
  6232.            { if (tolerantp) { return nullobj; }
  6233.              fehler_dir_not_exists(dir_namestring);
  6234.         }  }
  6235.       if (namenullp(STACK_0))
  6236.         { return dir_namestring; }
  6237.         else
  6238.         { return namestring_asciz(dir_namestring); }
  6239.     }
  6240.  
  6241. #endif
  6242.  
  6243. # UP: Liefert den Directory-Namestring eines Pathname unter der Annahme,
  6244. #     da▀ das Directory dieses Pathname existiert.
  6245. # assume_dir_exists()
  6246. # > STACK_0: absoluter Pathname ohne Wildcards im Directory
  6247. # < ergebnis:
  6248. #     falls Name=NIL: Directory-Namestring (fⁿr DOS bzw. GEMDOS, ohne Seriennummer)
  6249. #     falls Name/=NIL: Namestring (fⁿr DOS bzw. GEMDOS, ohne Seriennummer, mit Nullbyte am Schlu▀)
  6250. # kann GC ausl÷sen
  6251.   global object assume_dir_exists (void);
  6252.   global object assume_dir_exists()
  6253.     { var reg2 uintC stringcount =
  6254.         #if HAS_SERNR
  6255.         directory_namestring_parts(STACK_0,TRUE); # Strings fⁿrs Directory
  6256.         #else
  6257.         directory_namestring_parts(STACK_0); # Strings fⁿrs Directory
  6258.         #endif
  6259.       var reg1 object dir_namestring = string_concat(stringcount); # zusammenhΣngen
  6260.       if (namenullp(STACK_0))
  6261.         { return dir_namestring; }
  6262.         else
  6263.         { return namestring_asciz(dir_namestring); }
  6264.     }
  6265.  
  6266. #endif
  6267.  
  6268. #ifdef PATHNAME_AMIGAOS
  6269.  
  6270. # UP: Liefert den Truename eines Directory-Locks.
  6271. # > set_break_sem_4(): schon ausgefⁿhrt
  6272. # > lock: Directory-Lock, wird freigegeben
  6273. # < ergebnis: Directory (als Pathname)
  6274. # kann GC ausl÷sen
  6275.   local object directory_truename (BPTR lock);
  6276.   local object directory_truename(lock)
  6277.     var reg6 BPTR lock;
  6278.     { # Von hier aus hochhangeln:
  6279.       pushSTACK(NIL); # Subdir-Liste := NIL
  6280.       { var LONGALIGNTYPE(struct FileInfoBlock) fib;
  6281.         var reg5 struct FileInfoBlock * fibptr = LONGALIGN(&fib);
  6282.         loop
  6283.           { # Directory selbst ansehen:
  6284.             begin_system_call();
  6285.            {var reg1 LONG ergebnis = Examine(lock,fibptr);
  6286.             end_system_call();
  6287.             if (!ergebnis) { OS_error(); }
  6288.            }
  6289.             # seinen Namen verwenden:
  6290.            {var reg4 object name = asciz_to_string(&fibptr->fib_FileName[0]);
  6291.             # zum Parent-Directory hochsteigen:
  6292.             var reg3 BPTR parentlock;
  6293.             begin_system_call();
  6294.             parentlock = ParentDir(lock);
  6295.             UnLock(lock);
  6296.             end_system_call();
  6297.             if (!(parentlock==BPTR_NULL))
  6298.               # name ist der Name eines Subdirectories
  6299.               { # vor die Subdir-Liste pushen:
  6300.                 pushSTACK(name);
  6301.                {var reg1 object new_cons = allocate_cons();
  6302.                 Car(new_cons) = popSTACK();
  6303.                 Cdr(new_cons) = STACK_0;
  6304.                 STACK_0 = new_cons;
  6305.                }
  6306.                 lock = parentlock; # und vom Parent Directory aus weitermachen
  6307.               }
  6308.               else
  6309.               { begin_system_call();
  6310.                 if (IoErr()) { OS_error(); } # Fehler aufgetreten?
  6311.                 end_system_call();
  6312.                 # name ist der Name eines DOS-Volumes.
  6313.                 pushSTACK(name);
  6314.                 break;
  6315.               }
  6316.       }   }}
  6317.       clr_break_sem_4(); # Unterbrechungen wieder zulassen
  6318.       # Stackaufbau: subdirs, devicename.
  6319.      {# subdirs mit :ABSOLUTE anfangen lassen:
  6320.       var reg1 object new_cons = allocate_cons();
  6321.       Car(new_cons) = S(Kabsolute); Cdr(new_cons) = STACK_1;
  6322.       STACK_1 = new_cons;
  6323.      }
  6324.      {var reg1 object default_dir = allocate_pathname(); # neuer Pathname mit Name=NIL und Typ=NIL
  6325.       ThePathname(default_dir)->pathname_device = popSTACK();
  6326.       ThePathname(default_dir)->pathname_directory = popSTACK();
  6327.       return default_dir;
  6328.     }}
  6329.  
  6330. # UP: Liefert das aktuelle Directory.
  6331. # < ergebnis: aktuelles Directory (als Pathname)
  6332. # kann GC ausl÷sen
  6333.   local object default_directory (void);
  6334.   local object default_directory()
  6335.     { # Lock fⁿrs aktuelle Directory holen:
  6336.       set_break_sem_4(); # Unterbrechungen wΣhrenddessen verhindern
  6337.       begin_system_call();
  6338.      {var reg1 BPTR lock = Lock("",ACCESS_READ);
  6339.       if (lock==BPTR_NULL)
  6340.         { if (!(IoErr()==ERROR_OBJECT_NOT_FOUND)) { OS_error(); }
  6341.           pushSTACK(unbound); # "Wert" fⁿr Slot PATHNAME von FILE-ERROR
  6342.           fehler(file_error,
  6343.                  DEUTSCH ? "Zugriff auf aktuelles Verzeichnis nicht m÷glich." :
  6344.                  ENGLISH ? "Couldn't access current directory" :
  6345.                  FRANCAIS ? "Le rΘpertoire courant n'est pas accessible." :
  6346.                  ""
  6347.                 );
  6348.         }
  6349.       end_system_call();
  6350.       return directory_truename(lock); # macht clr_break_sem_4(); und UnLock(lock);
  6351.     }}
  6352.  
  6353. # UP: Fⁿllt Default-Directory in einen Pathname ein.
  6354. # use_default_dir(pathname)
  6355. # > pathname: nicht-Logical Pathname
  6356. # < ergebnis: neuer absoluter Pathname
  6357. # kann GC ausl÷sen
  6358.   local object use_default_dir (object pathname);
  6359.   local object use_default_dir(pathname)
  6360.     var reg3 object pathname;
  6361.     { # erst den Pathname kopieren:
  6362.       pathname = copy_pathname(pathname);
  6363.       # Dann das Default-Directory in den Pathname einbauen:
  6364.       { var reg2 object subdirs = ThePathname(pathname)->pathname_directory;
  6365.         # FΣngt pathname-directory mit :RELATIVE an?
  6366.         if (eq(Car(subdirs),S(Krelative)))
  6367.           { # ja -> Ersetze :RELATIVE durch default-subdirs, d.h.
  6368.             # bilde  (append default-subdirs (cdr subdirs))
  6369.             #      = (nreconc (reverse default-subdirs) (cdr subdirs))
  6370.             pushSTACK(pathname);
  6371.             pushSTACK(Cdr(subdirs));
  6372.            {var reg1 object temp = default_directory();
  6373.             temp = ThePathname(temp)->pathname_directory;
  6374.             temp = reverse(temp);
  6375.             subdirs = nreconc(temp,popSTACK());
  6376.             pathname = popSTACK();
  6377.             # in den Pathname eintragen:
  6378.             ThePathname(pathname)->pathname_directory = subdirs;
  6379.           }}
  6380.       }
  6381.       return pathname;
  6382.     }
  6383.  
  6384. # UP: Macht aus einem Directory-Namestring einen, der fⁿr AMIGAOS geeignet ist.
  6385. # OSnamestring(namestring)
  6386. # > namestring: neu erzeugter Directory-Namestring, mit '/' oder ':' am
  6387. #               Schlu▀, ein Simple-String
  6388. # < ergebnis: Namestring zu diesem Directory, im AmigaOS-Format: letzter '/'
  6389. #             gestrichen, falls ⁿberflⁿssig, ASCIZ-String
  6390. # kann GC ausl÷sen
  6391.   local object OSnamestring (object namestring);
  6392.   local object OSnamestring(namestring)
  6393.     var reg1 object namestring;
  6394.     { var reg2 uintL len = TheSstring(namestring)->length;
  6395.       if (len==0) goto ok; # Leerstring -> nichts streichen
  6396.      {var reg3 uintB ch = TheSstring(namestring)->data[len-1];
  6397.       if (!(ch=='/')) goto ok; # kein '/' am Schlu▀ -> nichts streichen
  6398.       if (len==1) goto ok; # "/" bedeutet Parent -> nicht streichen
  6399.       ch = TheSstring(namestring)->data[len-2];
  6400.       if ((ch=='/') || (ch==':')) # davor ein '/' oder ':'
  6401.         goto ok; # -> bedeutet Parent -> nicht streichen
  6402.       # '/' am Schlu▀ streichen, dann string_to_asciz:
  6403.         namestring = copy_string(namestring); # LΣnge bleibt dabei gleich!
  6404.         TheSstring(namestring)->data[len-1] = '\0';
  6405.         return namestring;
  6406.       ok: # nichts streichen
  6407.         return string_to_asciz(namestring);
  6408.     }}
  6409.  
  6410. # UP: Stellt sicher, da▀ das Directory eines Pathname existiert.
  6411. # assure_dir_exists(tolerantp)
  6412. # > STACK_0: nicht-Logical Pathname, bei dem Directory kein :RELATIVE enthΣlt.
  6413. # > tolerantp: Flag, ob ein Fehler vermieden werden soll
  6414. # > subr_self: Aufrufer (ein SUBR)
  6415. # < STACK_0: (evtl. derselbe) Pathname, aber aufgel÷st.
  6416. # < ergebnis:
  6417. #     falls Name=NIL: Directory-Namestring (fⁿr AMIGAOS, mit '/' am Schlu▀)
  6418. #     falls Name/=NIL: Namestring (fⁿr AMIGAOS, mit Nullbyte am Schlu▀)
  6419. #     falls tolerantp evtl.: nullobj
  6420. # < filestatus: Falls Name/=NIL: NULL falls das File nicht existiert,
  6421. #                                sonst ein Pointer auf eine STAT-Information.
  6422. # kann GC ausl÷sen
  6423.   local var struct FileInfoBlock * filestatus;
  6424.   local object assure_dir_exists (boolean tolerantp);
  6425.   local object assure_dir_exists(tolerantp)
  6426.     var reg5 boolean tolerantp;
  6427.     { # Zur Aufl÷sung von :PARENTs, die ⁿber Root hinaussteigen,
  6428.       # mⁿssen wir das Betriebssystem bemⁿhen. Daher:
  6429.       var reg3 object dir_namestring;
  6430.       {var reg1 uintC stringcount = directory_namestring_parts(STACK_0); # Strings fⁿrs Directory
  6431.        dir_namestring = string_concat(stringcount);
  6432.       }
  6433.       pushSTACK(dir_namestring);
  6434.       dir_namestring = OSnamestring(dir_namestring); # ohne ⁿberflⁿssigen '/' am Schlu▀
  6435.       # Lock fⁿr dieses Directory holen:
  6436.       set_break_sem_4(); # Unterbrechungen wΣhrenddessen verhindern
  6437.       begin_system_call();
  6438.      {var reg4 BPTR lock = Lock(TheAsciz(dir_namestring),ACCESS_READ);
  6439.       if (lock==BPTR_NULL)
  6440.         { var reg2 LONG errcode = IoErr();
  6441.           end_system_call();
  6442.           switch (errcode)
  6443.             { case ERROR_OBJECT_NOT_FOUND:
  6444.                 clr_break_sem_4();
  6445.                 if (tolerantp) { skipSTACK(1); return nullobj; }
  6446.                 fehler_dir_not_exists(STACK_0);
  6447.               case ERROR_ACTION_NOT_KNOWN:
  6448.                 # Ein Device, bei dem man keine Locks fⁿr Subdirectories holen
  6449.                 # kann! Hierbei mu▀ es sich wohl um ein spezielles Device handeln
  6450.                 # (PIPE, CON, AUX, etc.).
  6451.                 # Wir stoppen die Subdirectory-▄berprⁿfungen. Nicht einmal mehr
  6452.                 # Examine() rufen wir auf. Wir gehen im Gegenteil davon aus, da▀
  6453.                 # das File im gew÷hnlichen Sinne (noch) nicht existiert.
  6454.                 clr_break_sem_4(); # Unterbrechungen zulassen, da wir nun doch kein Lock belegt haben
  6455.                 if (namenullp(STACK_(0+1))) # kein File angesprochen?
  6456.                   { return popSTACK(); } # ja -> fertig
  6457.                   else
  6458.                   { var reg1 uintC stringcount = 1; # directory_namestring schon auf dem STACK
  6459.                     stringcount += file_namestring_parts(STACK_(0+1)); # Strings fⁿr den Filename
  6460.                     pushSTACK(O(null_string)); stringcount++; # und Nullbyte
  6461.                    {var reg2 object namestring = string_concat(stringcount); # zusammenhΣngen
  6462.                     filestatus = (struct FileInfoBlock *)NULL; # File existiert nicht, sagen wir
  6463.                     return namestring;
  6464.                   }}
  6465.               default:
  6466.                 OS_error();
  6467.         }   }
  6468.       end_system_call();
  6469.       dir_namestring = popSTACK();
  6470.       # und ⁿberprⁿfen, ob's ein Directory ist:
  6471.       { var LONGALIGNTYPE(struct FileInfoBlock) fib;
  6472.         var reg2 struct FileInfoBlock * fibptr = LONGALIGN(&fib);
  6473.         begin_system_call();
  6474.        {var reg1 LONG ergebnis = Examine(lock,fibptr);
  6475.         if (!ergebnis) { UnLock(lock); OS_error(); }
  6476.         if (!(fibptr->fib_DirEntryType > 0)) # etwa kein Directory?
  6477.           { UnLock(lock);
  6478.             end_system_call();
  6479.             if (tolerantp) { return nullobj; }
  6480.             # STACK_0 = Wert fⁿr Slot PATHNAME von FILE-ERROR
  6481.             pushSTACK(dir_namestring);
  6482.             pushSTACK(TheSubr(subr_self)->name);
  6483.             fehler(file_error,
  6484.                    DEUTSCH ? "~: ~ ist ein File und kein Directory." :
  6485.                    ENGLISH ? "~: ~ names a file, not a directory" :
  6486.                    FRANCAIS ? "~ : ~ est un fichier et non un rΘpertoire." :
  6487.                    ""
  6488.                   );
  6489.           }
  6490.         end_system_call();
  6491.       }}
  6492.       # Lock zum Truename machen:
  6493.       {var reg1 object new_pathname = directory_truename(lock); # macht clr_break_sem_4();
  6494.        var reg2 object old_pathname = STACK_0;
  6495.        ThePathname(new_pathname)->pathname_name = ThePathname(old_pathname)->pathname_name;
  6496.        ThePathname(new_pathname)->pathname_type = ThePathname(old_pathname)->pathname_type;
  6497.        STACK_0 = new_pathname;
  6498.      }}
  6499.      {var reg4 object pathname = STACK_0;
  6500.       # Information zum angesprochenen File holen:
  6501.       if (namenullp(pathname)) # kein File angesprochen?
  6502.         { return directory_namestring(pathname); } # ja -> fertig
  6503.       { var reg2 uintC stringcount = 0;
  6504.         stringcount += directory_namestring_parts(pathname); # Strings fⁿrs Directory
  6505.         stringcount += file_namestring_parts(pathname); # Strings fⁿr den Filename
  6506.         pushSTACK(O(null_string)); stringcount++; # und Nullbyte
  6507.        {var reg1 object namestring = string_concat(stringcount); # zusammenhΣngen
  6508.         # Lock fⁿr dieses File holen:
  6509.           begin_system_call();
  6510.         { var reg3 BPTR lock = Lock(TheAsciz(namestring),ACCESS_READ);
  6511.           if (lock==BPTR_NULL)
  6512.             { if (!(IoErr()==ERROR_OBJECT_NOT_FOUND)) { OS_error(); }
  6513.               end_system_call();
  6514.               # File existiert nicht.
  6515.               filestatus = (struct FileInfoBlock *)NULL; return namestring;
  6516.             }
  6517.           end_system_call();
  6518.           # File existiert.
  6519.           # Information holen:
  6520.          {local var LONGALIGNTYPE(struct FileInfoBlock) status;
  6521.           var reg1 struct FileInfoBlock * statusptr = LONGALIGN(&status);
  6522.           begin_system_call();
  6523.           if (! Examine(lock,statusptr) ) { UnLock(lock); OS_error(); }
  6524.           UnLock(lock);
  6525.           end_system_call();
  6526.           if (statusptr->fib_DirEntryType > 0) # Ist es ein Directory?
  6527.             { # STACK_0 = Wert fⁿr Slot PATHNAME von FILE-ERROR
  6528.               pushSTACK(whole_namestring(STACK_0));
  6529.               pushSTACK(TheSubr(subr_self)->name);
  6530.               fehler(file_error,
  6531.                      DEUTSCH ? "~: ~ ist ein Directory und kein File." :
  6532.                      ENGLISH ? "~: ~ names a directory, not a file" :
  6533.                      FRANCAIS ? "~ : ~ dΘsigne un rΘpertoire et non un fichier." :
  6534.                      ""
  6535.                     );
  6536.             }
  6537.             else
  6538.             # normales File
  6539.             { pushSTACK(namestring);
  6540.               # Die Gro▀-/Kleinschreibung des Truename wird bestimmt durch
  6541.               # das bereits existierende File.
  6542.               pushSTACK(asciz_to_string(&statusptr->fib_FileName[0]));
  6543.               split_name_type(1);
  6544.              {var reg1 object pathname = STACK_(0+3); # der kopierte Pathname
  6545.               ThePathname(pathname)->pathname_type = popSTACK();
  6546.               ThePathname(pathname)->pathname_name = popSTACK();
  6547.               # Fertig.
  6548.               filestatus = statusptr;
  6549.               return popSTACK(); # namestring
  6550.             }}
  6551.      }}}}}
  6552.     }
  6553.  
  6554. # Dasselbe unter der Annahme, da▀ das Directory bereits existiert.
  6555. # (Keine Vereinfachung, da wir ja den Truename bestimmen mⁿssen.)
  6556.   global object assume_dir_exists (void);
  6557.   global object assume_dir_exists()
  6558.     { subr_self = L(open); return assure_dir_exists(FALSE); }
  6559.  
  6560. #endif
  6561.  
  6562. #ifdef PATHNAME_UNIX
  6563.  
  6564. # UP: Liefert das aktuelle Directory.
  6565. # < ergebnis: aktuelles Directory (als Pathname)
  6566. # kann GC ausl÷sen
  6567.   local object default_directory (void);
  6568.   local object default_directory()
  6569.     # Working Directory (von UNIX) ist das aktuelle Directory:
  6570.     { var char path_buffer[MAXPATHLEN]; # vgl. GETWD(3)
  6571.       # Working Directory in path_buffer ablegen:
  6572.       begin_system_call();
  6573.       if ( getwd(&path_buffer[0]) ==NULL)
  6574.         { pushSTACK(O(punkt_string)); # Wert fⁿr Slot PATHNAME von FILE-ERROR
  6575.           pushSTACK(asciz_to_string(&path_buffer[0])); # Meldung
  6576.           fehler(file_error,
  6577.                  DEUTSCH ? "UNIX-Fehler bei GETWD: ~" :
  6578.                  ENGLISH ? "UNIX error while GETWD: ~" :
  6579.                  FRANCAIS ? "Erreur UNIX pendant GETWD : ~" :
  6580.                  "~"
  6581.                 );
  6582.         }
  6583.       end_system_call();
  6584.       # Es mu▀ mit '/' anfangen:
  6585.       if (!(path_buffer[0] == '/'))
  6586.         { pushSTACK(O(punkt_string)); # Wert fⁿr Slot PATHNAME von FILE-ERROR
  6587.           pushSTACK(asciz_to_string(&path_buffer[0]));
  6588.           fehler(file_error,
  6589.                  DEUTSCH ? "UNIX GETWD lieferte ~" :
  6590.                  ENGLISH ? "UNIX GETWD returned ~" :
  6591.                  FRANCAIS ? "GETWD d'UNIX a retournΘ ~" :
  6592.                  ""
  6593.                 );
  6594.         }
  6595.       # in Pathname umwandeln:
  6596.       return asciz_dir_to_pathname(&path_buffer[0]);
  6597.     }
  6598.  
  6599. # UP: Fⁿllt Default-Directory in einen Pathname ein.
  6600. # use_default_dir(pathname)
  6601. # > pathname: nicht-Logical Pathname
  6602. # < ergebnis: neuer Pathname, bei dem Directory kein :RELATIVE enthΣlt.
  6603. #             (kurz: "absoluter Pathname")
  6604. # kann GC ausl÷sen
  6605.   local object use_default_dir (object pathname);
  6606.   local object use_default_dir(pathname)
  6607.     var reg3 object pathname;
  6608.     { # erst den Pathname kopieren:
  6609.       pathname = copy_pathname(pathname);
  6610.       # Dann das Default-Directory in den Pathname einbauen:
  6611.       { var reg2 object subdirs = ThePathname(pathname)->pathname_directory;
  6612.         # FΣngt pathname-directory mit :RELATIVE an?
  6613.         if (eq(Car(subdirs),S(Krelative)))
  6614.           { # ja -> Ersetze :RELATIVE durch default-subdirs, d.h.
  6615.             # bilde  (append default-subdirs (cdr subdirs))
  6616.             #      = (nreconc (reverse default-subdirs) (cdr subdirs))
  6617.             pushSTACK(pathname);
  6618.             pushSTACK(Cdr(subdirs));
  6619.            {var reg1 object temp = default_directory();
  6620.             temp = ThePathname(temp)->pathname_directory;
  6621.             temp = reverse(temp);
  6622.             subdirs = nreconc(temp,popSTACK());
  6623.             pathname = popSTACK();
  6624.             # in den Pathname eintragen:
  6625.             ThePathname(pathname)->pathname_directory = subdirs;
  6626.           }}
  6627.       }
  6628.       return pathname;
  6629.     }
  6630.  
  6631. # UP: Stellt sicher, da▀ das Directory eines Pathname existiert, und l÷st
  6632. # dabei symbolische Links auf.
  6633. # assure_dir_exists(tolerantp)
  6634. # > STACK_0: nicht-Logical Pathname, bei dem Directory kein :RELATIVE enthΣlt.
  6635. # > tolerantp: Flag, ob ein Fehler vermieden werden soll
  6636. # > subr_self: Aufrufer (ein SUBR)
  6637. # < STACK_0: (evtl. derselbe) Pathname, wobei weder fⁿrs Directory noch
  6638. #            fⁿr den Filenamen ein symbolisches Link zu verfolgen ist.
  6639. # < ergebnis:
  6640. #     falls Name=NIL: Directory-Namestring (fⁿr UNIX, mit '/' am Schlu▀)
  6641. #     falls Name/=NIL: Namestring (fⁿr UNIX, mit Nullbyte am Schlu▀)
  6642. #     falls tolerantp evtl.: nullobj
  6643. # < filestatus: Falls Name/=NIL: NULL falls das File nicht existiert,
  6644. #                                sonst ein Pointer auf eine STAT-Information.
  6645. # kann GC ausl÷sen
  6646.   local var struct stat * filestatus;
  6647.   local object assure_dir_exists (boolean tolerantp);
  6648.   local object assure_dir_exists(tolerantp)
  6649.     var reg7 boolean tolerantp;
  6650.     { var reg6 uintC allowed_links = MAXSYMLINKS; # Anzahl der noch erlaubten symbolischen Links
  6651.       loop # Schleife ⁿber die aufzul÷senden symbolischen Links
  6652.         { # Truepath des Directory bestimmen:
  6653.           var char path_buffer[MAXPATHLEN]; # vgl. REALPATH(3)
  6654.           { var reg2 uintC stringcount = directory_namestring_parts(STACK_0); # Strings zum Directory
  6655.             pushSTACK(O(punkt_string)); # und "."
  6656.             pushSTACK(O(null_string)); # und Nullbyte
  6657.            {var reg1 object string = string_concat(stringcount+1+1); # zusammenhΣngen
  6658.             # symbolische Links darin aufl÷sen:
  6659.             begin_system_call();
  6660.             if ( realpath(TheAsciz(string),&path_buffer[0]) ==NULL)
  6661.               { end_system_call();
  6662.                 if (!(errno==ENOENT)) { OS_error(); }
  6663.                 if (tolerantp) { return nullobj; }
  6664.                 fehler_dir_not_exists(asciz_dir_to_pathname(&path_buffer[0])); # fehlerhafte Komponente
  6665.               }
  6666.             end_system_call();
  6667.           }}
  6668.           # Neuer Directory-Path mu▀ mit '/' anfangen:
  6669.           if (!(path_buffer[0] == '/'))
  6670.             { # STACK_0 = Wert fⁿr Slot PATHNAME von FILE-ERROR
  6671.               pushSTACK(asciz_to_string(&path_buffer[0]));
  6672.               fehler(file_error,
  6673.                      DEUTSCH ? "UNIX REALPATH lieferte ~" :
  6674.                      ENGLISH ? "UNIX REALPATH returned ~" :
  6675.                      FRANCAIS ? "REALPATH d'UNIX a retournΘ ~" :
  6676.                      ""
  6677.                     );
  6678.             }
  6679.           # Am Schlu▀ evtl. ein '/' anfⁿgen:
  6680.           {var reg1 char* pathptr = &path_buffer[0];
  6681.            var reg2 uintL len = 0; # StringlΣnge
  6682.            until (*pathptr == 0) { pathptr++; len++; } # ASCIZ-Stringende suchen
  6683.            if (!((len>0) && (pathptr[-1]=='/')))
  6684.              { *pathptr = '/'; len++; } # ein '/' anfⁿgen
  6685.           # und in einen String umwandeln:
  6686.            { var reg4 object new_string = make_string((uintB*)(&path_buffer[0]),len);
  6687.           # Pathname draus machen und dessen Directory verwenden:
  6688.             {var reg3 object new_pathname = coerce_pathname(new_string);
  6689.              ThePathname(STACK_0)->pathname_directory
  6690.                = ThePathname(new_pathname)->pathname_directory;
  6691.           }}}
  6692.           # Information zum angesprochenen File holen:
  6693.           if (namenullp(STACK_0)) # kein File angesprochen?
  6694.             { return directory_namestring(STACK_0); } # ja -> fertig
  6695.           { var reg5 object pathname = STACK_0;
  6696.             var reg2 uintC stringcount = 0;
  6697.             stringcount += directory_namestring_parts(pathname); # Strings fⁿrs Directory
  6698.             stringcount += file_namestring_parts(pathname); # Strings fⁿr den Filename
  6699.             pushSTACK(O(null_string)); stringcount++; # und Nullbyte
  6700.            {var reg1 object namestring = string_concat(stringcount); # zusammenhΣngen
  6701.             # Information holen:
  6702.             local struct stat status;
  6703.             begin_system_call();
  6704.             if (!( lstat(TheAsciz(namestring),&status) ==0))
  6705.               { if (!(errno==ENOENT)) { OS_error(); }
  6706.                 # File existiert nicht.
  6707.                 end_system_call();
  6708.                 filestatus = (struct stat *)NULL; return namestring;
  6709.               }
  6710.             end_system_call();
  6711.             # File existiert.
  6712.             if (S_ISDIR(status.st_mode)) # Ist es ein Directory?
  6713.               { # STACK_0 = Wert fⁿr Slot PATHNAME von FILE-ERROR
  6714.                 pushSTACK(whole_namestring(STACK_0));
  6715.                 pushSTACK(TheSubr(subr_self)->name);
  6716.                 fehler(file_error,
  6717.                        DEUTSCH ? "~: ~ ist ein Directory und kein File." :
  6718.                        ENGLISH ? "~: ~ names a directory, not a file" :
  6719.                        FRANCAIS ? "~ : ~ est un rΘpertoire et non un fichier." :
  6720.                        ""
  6721.                       );
  6722.               }
  6723.             #ifdef HAVE_LSTAT
  6724.             elif (S_ISLNK(status.st_mode)) # Ist es ein symbolisches Link?
  6725.               # ja -> weiterverfolgen:
  6726.               { if (allowed_links==0) # keine Links mehr erlaubt?
  6727.                   { errno = ELOOP_VALUE; OS_error(); } # ja -> UNIX-Error ELOOP simulieren
  6728.                 allowed_links--; # danach ist ein Link weniger erlaubt
  6729.                {var reg4 uintL linklen = status.st_size; # vermutliche LΣnge des Link-Inhalts
  6730.                 retry_readlink:
  6731.                   pushSTACK(namestring); # Namestring retten
  6732.                 { var reg3 object linkbuf = allocate_string(linklen); # Buffer fⁿr den Link-Inhalt
  6733.                   namestring = popSTACK();
  6734.                   # Link-Inhalt lesen:
  6735.                   begin_system_call();
  6736.                  {var reg1 int result = readlink(TheAsciz(namestring),TheAsciz(linkbuf),linklen);
  6737.                   end_system_call();
  6738.                   if (result<0)
  6739.                     { OS_error(); }
  6740.                   if (!(result == linklen)) # manchmal (AIX, NFS) stimmt status.st_size nicht
  6741.                     { linklen = result; goto retry_readlink; }
  6742.                   # Daraus ein Pathname machen:
  6743.                   # (MERGE-PATHNAMES (PARSE-NAMESTRING linkbuf) pathname)
  6744.                   pushSTACK(linkbuf); funcall(L(parse_namestring),1);
  6745.                   pushSTACK(value1); pushSTACK(STACK_(0+1)); funcall(L(merge_pathnames),2);
  6746.                   STACK_0 = value1;
  6747.               }}}}
  6748.             #endif
  6749.             else
  6750.               # normales File
  6751.               { filestatus = &status; return namestring; }
  6752.           }}
  6753.     }   }
  6754.  
  6755. # Dasselbe unter der Annahme, da▀ das Directory bereits existiert.
  6756. # (Keine Vereinfachung, da das File ein symbolisches Link in ein anderes
  6757. # Directory sein kann, und dieses mu▀ dann als existent ⁿberprⁿft werden.)
  6758.   global object assume_dir_exists (void);
  6759.   global object assume_dir_exists()
  6760.     { subr_self = L(open); return assure_dir_exists(FALSE); }
  6761.  
  6762. #endif
  6763.  
  6764. #ifdef PATHNAME_RISCOS
  6765.  
  6766. # Ein "absoluter Pathname" ist ein Pathname, bei dem Directory mit
  6767. # (:ABSOLUTE :ROOT ...) beginnt.
  6768.  
  6769. # UP: Liefert das aktuelle Directory.
  6770. # < ergebnis: aktuelles Directory (als Pathname)
  6771. # kann GC ausl÷sen
  6772.   local object default_directory (void);
  6773.   local object default_directory()
  6774.     # Working Directory (von RISCOS) ist das aufgel÷ste "@":
  6775.     { var char path_buffer[MAXPATHLEN];
  6776.       # Working Directory in path_buffer ablegen:
  6777.       begin_system_call();
  6778.       if ( realpath("@",&path_buffer[0]) ==NULL) { OS_error(); }
  6779.       end_system_call();
  6780.       # in Pathname umwandeln:
  6781.       return asciz_dir_to_pathname(&path_buffer[0]);
  6782.     }
  6783.  
  6784. #if 0 # unbenutzt
  6785. # UP: Convert a valid RISCOS file namestring to an absolute pathname.
  6786. # canonicalise_filename(filename)
  6787. # > filename: Simple-Asciz-String
  6788. # < result: absolute pathname
  6789.   local object canonicalise_filename (object filename);
  6790.   local object canonicalise_filename(filename)
  6791.     var reg1 object filename;
  6792.     { var char path_buffer[MAXPATHLEN];
  6793.       begin_system_call();
  6794.       if ( realpath(TheAsciz(filename),&path_buffer[0]) ==NULL) { OS_error(); }
  6795.       end_system_call();
  6796.       # in Pathname umwandeln:
  6797.       return coerce_pathname(asciz_to_string(&path_buffer[0]));
  6798.     }
  6799. #endif
  6800.  
  6801. # UP: Convert a valid RISCOS directory namestring to an absolute pathname.
  6802. # canonicalise_dirname(pathname,dirname)
  6803. # > pathname: Pathname whose host name and device is to be used
  6804. # > dirname: Simple-String, ends with '.'
  6805. # < result: absolute pathname
  6806.   local object canonicalise_dirname (object pathname, object dirname);
  6807.   local object canonicalise_dirname(pathname,dirname)
  6808.     var reg5 object pathname;
  6809.     var reg4 object dirname;
  6810.     { var reg3 uintC stringcount = host_namestring_parts(pathname); # Strings fⁿr den Host
  6811.       # Device, vgl. directory_namestring_parts():
  6812.       { var reg1 object device = ThePathname(pathname)->pathname_device;
  6813.         if (!(nullp(device))) # NIL -> kein String
  6814.           { pushSTACK(O(doppelpunkt_string)); # ":"
  6815.             pushSTACK(device); # Device auf den Stack
  6816.             pushSTACK(O(punkt_string)); # "."
  6817.             stringcount += 3; # und mitzΣhlen
  6818.       }   }
  6819.       pushSTACK(dirname);
  6820.      {var reg1 object dir_string = string_concat(stringcount+1);
  6821.       # Punkt am Schlu▀ durch Nullbyte ersetzen:
  6822.       TheSstring(dir_string)->data[TheSstring(dir_string)->length-1] = '\0';
  6823.       # absolut machen:
  6824.       { var char path_buffer[MAXPATHLEN];
  6825.         begin_system_call();
  6826.         if ( realpath(TheAsciz(dir_string),&path_buffer[0]) ==NULL) { OS_error(); }
  6827.         end_system_call();
  6828.         # in Pathname umwandeln:
  6829.         return asciz_dir_to_pathname(&path_buffer[0]);
  6830.     }}}
  6831.  
  6832. # UP: Fⁿllt Default-Directory in einen Pathname ein.
  6833. # use_default_dir(pathname)
  6834. # > pathname: nicht-Logical Pathname
  6835. # < ergebnis: neuer Pathname, bei dem Directory kein :RELATIVE u.Σ. enthΣlt.
  6836. #             (kurz: "absoluter Pathname")
  6837. # kann GC ausl÷sen
  6838.   local object use_default_dir (object pathname);
  6839.   local object use_default_dir(pathname)
  6840.     var reg3 object pathname;
  6841.     { var reg5 boolean resolved_root = FALSE;
  6842.       retry:
  6843.       # erst den Pathname kopieren:
  6844.       pathname = copy_pathname(pathname);
  6845.      {var reg2 object subdirs = ThePathname(pathname)->pathname_directory;
  6846.       # Ist das Device angegeben, so mu▀ das Directory mit (:ABSOLUTE :ROOT ...)
  6847.       # anfangen (oder mit (:RELATIVE ...) - das wird ersetzt).
  6848.       if (!nullp(ThePathname(pathname)->pathname_device))
  6849.         { if (eq(Car(subdirs),S(Krelative)))
  6850.             { pushSTACK(pathname); # pathname retten
  6851.               pushSTACK(allocate_cons());
  6852.              {var reg1 object new_cons = allocate_cons();
  6853.               subdirs = popSTACK();
  6854.               pathname = popSTACK(); # pathname zurⁿck
  6855.               Car(subdirs) = S(Kabsolute); Cdr(subdirs) = new_cons;
  6856.               Car(new_cons) = S(Kroot); Cdr(new_cons) = Cdr(ThePathname(pathname)->pathname_directory);
  6857.               ThePathname(pathname)->pathname_directory = subdirs;
  6858.             }}
  6859.           elif (!(eq(Car(subdirs),S(Kabsolute)) && eq(Car(Cdr(subdirs)),S(Kroot))))
  6860.             { pushSTACK(pathname); # Wert fⁿr Slot PATHNAME von FILE-ERROR
  6861.               pushSTACK(pathname);
  6862.               pushSTACK(O(root_string));
  6863.               pushSTACK(TheSubr(subr_self)->name);
  6864.               fehler(file_error,
  6865.                      DEUTSCH ? "~: Ist ein Device angegeben, mu▀ das Directory mit ~ anfangen: ~" :
  6866.                      ENGLISH ? "~: If a device is specified, the directory must begin with ~: ~" :
  6867.                      FRANCAIS ? "~ : Quand un composant DEVICE est spΘcifiΘ, le rΘpertoire doit commencer par ~: ~" :
  6868.                      ""
  6869.                     );
  6870.             }
  6871.         }
  6872.       pushSTACK(pathname); # pathname retten
  6873.       {var reg4 object defaults;
  6874.        if (eq(Car(subdirs),S(Krelative)))
  6875.          { pushSTACK(Cdr(subdirs)); defaults = default_directory(); }
  6876.        else # (eq(Car(subdirs),S(Kabsolute)))
  6877.          { var reg1 object next = Car(Cdr(subdirs));
  6878.            pushSTACK(Cdr(Cdr(subdirs)));
  6879.            if (eq(next,S(Kroot))) # :ROOT -> "$." aufl÷sen oder fertig
  6880.              { # "$." wird nur dann aufgel÷st, wenn Host oder Device noch
  6881.                # unbekannt sind, aber nur einmal (um eine Endlosschleife zu
  6882.                # verhindern). Ob Host oder Device =NIL sind, ist nΣmlich
  6883.                # nicht so wichtig.
  6884.                if (!resolved_root
  6885.                    && (nullp(ThePathname(pathname)->pathname_host)
  6886.                        || nullp(ThePathname(pathname)->pathname_device)
  6887.                   )   )
  6888.                  { defaults = canonicalise_dirname(pathname,O(root_string));
  6889.                    resolved_root = TRUE;
  6890.                  }
  6891.                else
  6892.                  { goto resolved; }
  6893.              }
  6894.            elif (eq(next,S(Khome))) # :HOME -> "&." aufl÷sen
  6895.              { defaults = canonicalise_dirname(pathname,O(home_string)); }
  6896.            elif (eq(next,S(Kcurrent))) # :CURRENT -> "@." aufl÷sen
  6897.              { defaults = canonicalise_dirname(pathname,O(current_string)); }
  6898.            elif (eq(next,S(Klibrary))) # :LIBRARY -> "%." aufl÷sen
  6899.              { defaults = canonicalise_dirname(pathname,O(library_string)); }
  6900.            elif (eq(next,S(Kprevious))) # :PREVIOUS -> "\\." aufl÷sen
  6901.              { defaults = canonicalise_dirname(pathname,O(previous_string)); }
  6902.            else
  6903.              { NOTREACHED }
  6904.          }
  6905.        # Stackaufbau: pathname, rest-subdirs.
  6906.        # Nicht ganz so wie bei MERGE-PATHNAMES verfahren:
  6907.        # bilde  (append default-subdirs rest-subdirs)
  6908.        #      = (nreconc (reverse default-subdirs) rest-subdirs)
  6909.        pathname = STACK_1;
  6910.        ThePathname(pathname)->pathname_host = ThePathname(defaults)->pathname_host;
  6911.        ThePathname(pathname)->pathname_device = ThePathname(defaults)->pathname_device;
  6912.        defaults = ThePathname(defaults)->pathname_directory;
  6913.        defaults = reverse(defaults); subdirs = nreconc(defaults,popSTACK());
  6914.        pathname = popSTACK();
  6915.        ThePathname(pathname)->pathname_directory = subdirs;
  6916.        # Es k÷nnte sein, da▀ auch jetzt noch nicht alles aufgel÷st ist.
  6917.        goto retry;
  6918.      }}
  6919.      resolved: # Stackaufbau: pathname, subdir-oldlist.
  6920.       # Liste durchgehen und dabei neu aufconsen, dabei "^." verarbeiten.
  6921.       # (Sonst mⁿ▀te dies assure_dir_exists() machen.)
  6922.       pushSTACK(S(Kroot)); pushSTACK(S(Kabsolute));
  6923.       { var reg1 object newlist = listof(2); pushSTACK(newlist); }
  6924.       # Stackaufbau: pathname, subdir-oldlist, subdir-newlist.
  6925.       while (mconsp(STACK_1)) # Bis oldlist am Ende ist:
  6926.         { var reg4 object subdir = Car(STACK_1); # nΣchstes subdir
  6927.           if (eq(subdir,S(Kparent)))
  6928.             # = :PARENT -> newlist um eins verkⁿrzen:
  6929.             { if (matomp(Cdr(Cdr(STACK_0)))) # newlist (bis auf :ABSOLUTE und :ROOT) leer ?
  6930.                 { # :PARENT von "$." aus liefert Error
  6931.                   pushSTACK(STACK_2); # Wert fⁿr Slot PATHNAME von FILE-ERROR
  6932.                   pushSTACK(O(root_string)); # "$."
  6933.                   pushSTACK(directory_namestring(STACK_(2+2))); # Directory von pathname
  6934.                   fehler(file_error,
  6935.                          DEUTSCH ? "Directory ~ oberhalb ~ existiert nicht." :
  6936.                          ENGLISH ? "no directory ~ above ~" :
  6937.                          FRANCAIS ? "Il n'y a pas de rΘpertoire ~ au delα de ~." :
  6938.                          ""
  6939.                         );
  6940.                 }
  6941.               STACK_0 = Cdr(STACK_0);
  6942.             }
  6943.           else
  6944.             { # newlist um eins verlΣngern:
  6945.               pushSTACK(subdir);
  6946.              {var reg1 object new_cons = allocate_cons();
  6947.               Car(new_cons) = popSTACK();
  6948.               Cdr(new_cons) = STACK_0;
  6949.               STACK_0 = new_cons;
  6950.             }}
  6951.           STACK_1 = Cdr(STACK_1);
  6952.         }
  6953.      {var reg2 object subdirs = nreverse(popSTACK()); # newlist, wieder umdrehen
  6954.       skipSTACK(1);
  6955.       pathname = popSTACK();
  6956.       ThePathname(pathname)->pathname_directory = subdirs; # in den Pathname eintragen
  6957.       return pathname;
  6958.     }}
  6959.  
  6960. # UP: Liefert den Namestring eines Pathname als ASCIZ-String.
  6961. # namestring_asciz(dir_namestring)
  6962. # > STACK_0: nicht-Logical Pathname
  6963. # > dir_namestring: Directory-Namestring
  6964. # < ergebnis: Namestring (fⁿr RISCOS, mit Name/Type vertauscht, mit Nullbyte am Schlu▀)
  6965. # kann GC ausl÷sen
  6966.   local object namestring_asciz (object dir_namestring);
  6967.   local object namestring_asciz(dir_namestring)
  6968.     var reg3 object dir_namestring;
  6969.     { var reg1 object pathname = STACK_0;
  6970.       var reg2 uintC stringcount;
  6971.       pushSTACK(dir_namestring); # Directory-Namestring als 1. String
  6972.       stringcount = # und Strings zum Filenamen
  6973.         (nullp(ThePathname(pathname)->pathname_type)
  6974.          ? nametype_namestring_parts(ThePathname(pathname)->pathname_name,
  6975.                                      ThePathname(pathname)->pathname_type,
  6976.                                      ThePathname(pathname)->pathname_version)
  6977.          # Name und Typ vertauschen (der Typ wird zu einem Subdirectory-Namen):
  6978.          : nametype_namestring_parts(ThePathname(pathname)->pathname_type,
  6979.                                      ThePathname(pathname)->pathname_name,
  6980.                                      ThePathname(pathname)->pathname_version)
  6981.         );
  6982.       pushSTACK(O(null_string)); # und String mit Nullbyte
  6983.       return string_concat(1+stringcount+1); # zusammenhΣngen
  6984.     }
  6985.  
  6986. # UP: Stellt sicher, da▀ das Directory eines Pathname existiert.
  6987. # Sonst Fehlermeldung.
  6988. # assure_dir_exists(tolerantp)
  6989. # > STACK_0: absoluter Pathname ohne Wildcards im Directory
  6990. # > tolerantp: Flag, ob ein Fehler vermieden werden soll
  6991. # < ergebnis:
  6992. #     falls Name=NIL: Directory-Namestring (fⁿr RISCOS, mit '.' am Schlu▀)
  6993. #     falls Name/=NIL: Namestring (fⁿr RISCOS, mit Nullbyte am Schlu▀)
  6994. #     falls tolerantp evtl.: nullobj
  6995. # < filestatus: Falls Name/=NIL: NULL falls das File nicht existiert,
  6996. #                                sonst ein Pointer auf eine STAT-Information.
  6997. # kann GC ausl÷sen
  6998.   local var struct stat * filestatus;
  6999.   local object assure_dir_exists (boolean tolerantp);
  7000.   local object assure_dir_exists(tolerantp)
  7001.     var reg5 boolean tolerantp;
  7002.     { var reg4 object pathname = STACK_0;
  7003.       var reg2 uintC stringcount = host_namestring_parts(pathname); # Strings fⁿr den Host
  7004.       stringcount += directory_namestring_parts(pathname); # Strings fⁿrs Directory
  7005.      {var reg1 object dir_namestring = string_concat(stringcount); # zusammenhΣngen
  7006.       # Existenztest:
  7007.       var struct stat statbuf;
  7008.       var reg1 uintL len = TheSstring(dir_namestring)->length;
  7009.       ASSERT((len > 0) && (TheSstring(dir_namestring)->data[len-1]=='.'));
  7010.       TheSstring(dir_namestring)->data[len-1] = '\0'; # '.' am Schlu▀ durch Nullbyte ersetzen
  7011.       begin_system_call();
  7012.       if (stat(TheAsciz(dir_namestring),&statbuf) < 0)
  7013.         { end_system_call();
  7014.           if (tolerantp && (errno==ENOENT)) { return nullobj; }
  7015.           OS_error();
  7016.         }
  7017.       end_system_call();
  7018.       TheSstring(dir_namestring)->data[len-1] = '.'; # '.' wieder zurⁿck
  7019.       if (!S_ISDIR(statbuf.st_mode)) # gefundene Datei kein Unterdirectory ?
  7020.         { if (tolerantp) { return nullobj; }
  7021.           fehler_dir_not_exists(dir_namestring);
  7022.         }
  7023.       # Information zum angesprochenen File holen:
  7024.       if (namenullp(STACK_0)) # kein File angesprochen?
  7025.         { return dir_namestring; } # ja -> fertig
  7026.         else
  7027.         { var reg3 object namestring = namestring_asciz(dir_namestring);
  7028.           # Information holen:
  7029.           local struct stat status;
  7030.           begin_system_call();
  7031.           if (stat(TheAsciz(namestring),&status) < 0)
  7032.             { if (!(errno==ENOENT)) { OS_error(); }
  7033.               # File existiert nicht.
  7034.               end_system_call();
  7035.               filestatus = (struct stat *)NULL; return namestring;
  7036.             }
  7037.           end_system_call();
  7038.           # File existiert.
  7039.           if (S_ISDIR(status.st_mode)) # Ist es ein Directory?
  7040.             { # STACK_0 = Wert fⁿr Slot PATHNAME von FILE-ERROR
  7041.               pushSTACK(whole_namestring(STACK_0));
  7042.               pushSTACK(TheSubr(subr_self)->name);
  7043.               fehler(file_error,
  7044.                      DEUTSCH ? "~: ~ ist ein Directory und kein File." :
  7045.                      ENGLISH ? "~: ~ names a directory, not a file" :
  7046.                      FRANCAIS ? "~ : ~ est un rΘpertoire et non un fichier." :
  7047.                      ""
  7048.                     );
  7049.             }
  7050.           else
  7051.             # normales File
  7052.             { filestatus = &status; return namestring; }
  7053.     }}  }
  7054.  
  7055. # Dasselbe unter der Annahme, da▀ das Directory bereits existiert.
  7056. # (Keine Vereinfachung, da wir ja den Truename bestimmen mⁿssen.)
  7057.   global object assume_dir_exists (void);
  7058.   global object assume_dir_exists()
  7059.     { subr_self = L(open); return assure_dir_exists(FALSE); }
  7060.  
  7061. # Ein File "name.type" wird dem RISCOS als "type.name" vermittelt, dabei ist
  7062. # "type" der Name eines Unterverzeichnisses! Soll ein File "name.type" angelegt
  7063. # werden, mu▀ daher zuerst das Unterverzeichnis "type" erzeugt werden.
  7064. # prepare_create(pathname);
  7065. # > pathname: ein Pathname
  7066. # kann GC ausl÷sen
  7067.   local void prepare_create (object pathname);
  7068.   local object pathname_add_subdir (void);
  7069.   local void prepare_create(pathname)
  7070.     var reg1 object pathname;
  7071.     { if (!nullp(ThePathname(pathname)->pathname_type))
  7072.         { # call pathname_add_subdir:
  7073.           pushSTACK(pathname); pushSTACK(ThePathname(pathname)->pathname_type);
  7074.           pathname = pathname_add_subdir();
  7075.           ThePathname(pathname)->pathname_name = NIL;
  7076.           ThePathname(pathname)->pathname_type = NIL;
  7077.           # call MAKE-DIR if the directory does not exist:
  7078.           pushSTACK(subr_self); # subr_self retten
  7079.           pushSTACK(pathname);
  7080.           if (eq(assure_dir_exists(TRUE),nullobj))
  7081.             { funcall(L(make_dir),1); }
  7082.           else
  7083.             { skipSTACK(1); }
  7084.           subr_self = popSTACK(); # subr_self zurⁿck
  7085.     }   }
  7086.  
  7087. #endif
  7088.  
  7089. #ifdef PATHNAME_ATARI
  7090. # UP: Setzt das Default-Drive und sein Default-Directory neu.
  7091. # change_default();
  7092. # > STACK_0: absoluter Pathname, bei dem Name und Typ =NIL sind.
  7093. # kann GC ausl÷sen
  7094.   local void change_default (void);
  7095.   local void change_default()
  7096.     { # Default-Directory zu diesem Drive neu setzen:
  7097.       var reg3 object alist = get_drive_alist(STACK_0); # Alisteneintrag zu diesem Device
  7098.       var reg2 object seriennummer = Car(ThePathname(STACK_0)->pathname_directory);
  7099.       {var reg1 object alistr = alist; # Alisteneintrag durchlaufen
  7100.        while (consp(alistr=Cdr(alistr)))
  7101.          { var reg1 object entry = Car(alistr);
  7102.            if (eq(Car(entry),seriennummer))
  7103.              { # die gegebene Seriennummer im Alisteneintrag gefunden.
  7104.                Cdr(entry) = STACK_0; # (car entry) = seriennummer, (cdr entry) := pathname
  7105.                goto default_dir_ok;
  7106.              }
  7107.       }  }
  7108.       # Bisher (auf diesem Drive) unbekannte Diskette.
  7109.       pushSTACK(alist); # Alisteneintrag retten
  7110.       {var reg1 object new_cons = allocate_cons(); # Neues Cons
  7111.        Car(new_cons) = seriennummer; Cdr(new_cons) = STACK_1;
  7112.        pushSTACK(new_cons); # (cons seriennummer pathname) retten
  7113.        new_cons = allocate_cons(); # neues Cons
  7114.        Car(new_cons) = popSTACK();
  7115.        # new_cons = (list (cons seriennummer pathname))
  7116.        alist = popSTACK();
  7117.        # Alisteneintrag um die 1-elementige Liste new_cons erweitern:
  7118.        Cdr(new_cons) = Cdr(alist); Cdr(alist) = new_cons;
  7119.       }
  7120.       default_dir_ok:
  7121.       # Default-Drive neu setzen:
  7122.       O(default_drive) = ThePathname(STACK_0)->pathname_device;
  7123.       # *DEFAULT-PATHNAME-DEFAULTS* neu setzen:
  7124.       recalc_defaults_pathname();
  7125.     }
  7126. #endif
  7127. #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  7128. #if 0 # unbenutzt
  7129. # UP: Macht aus einem Directory-Namestring einen, der fⁿr DOS geeignet ist.
  7130. # OSnamestring(namestring)
  7131. # > namestring: neu erzeugter Directory-Namestring, mit '\' am Schlu▀,
  7132. #               ein Simple-String
  7133. # < ergebnis: Namestring zu diesem Directory, im DOS-Format: letzter '\'
  7134. #             gestrichen, falls ⁿberflⁿssig, ASCIZ-String
  7135. # kann GC ausl÷sen
  7136.   local object OSnamestring (object namestring);
  7137.   local object OSnamestring(namestring)
  7138.     var reg1 object namestring;
  7139.     { var reg2 uintL len = TheSstring(namestring)->length;
  7140.       if (len==0) goto ok; # Leerstring -> nichts streichen
  7141.      {var reg3 uintB ch = TheSstring(namestring)->data[len-1];
  7142.       if (!(ch=='\\')) goto ok; # kein '\' am Schlu▀ -> nichts streichen
  7143.       if (len==1) goto ok; # "\" bedeutet Root -> nicht streichen
  7144.       ch = TheSstring(namestring)->data[len-2];
  7145.       if ((ch=='\\') || (ch==':')) # davor ein '\' oder ':'
  7146.         goto ok; # -> bedeutet Parent -> nicht streichen
  7147.       # '\' am Schlu▀ streichen, dann string_to_asciz:
  7148.         namestring = copy_string(namestring); # LΣnge bleibt dabei gleich!
  7149.         TheSstring(namestring)->data[len-1] = '\0';
  7150.         return namestring;
  7151.       ok: # nichts streichen
  7152.         return string_to_asciz(namestring);
  7153.     }}
  7154. #endif
  7155. # UP: Setzt das Default-Drive und sein Default-Directory neu.
  7156. # change_default();
  7157. # > STACK_0: absoluter Pathname, bei dem Device ein String ist und Directory
  7158. #     kein :RELATIVE, :CURRENT, :PARENT enthΣlt, und Name und Typ =NIL sind.
  7159. # kann GC ausl÷sen
  7160.   local void change_default (void);
  7161.   local void change_default()
  7162.     { # Default-Directory zu diesem Drive neu setzen:
  7163.       { var reg1 object pathname = STACK_0;
  7164.         var reg3 uintC stringcount =
  7165.           directory_namestring_parts(pathname); # Strings fⁿrs Directory
  7166.         # ohne ⁿberflⁿssiges '\' am Schlu▀, aber mit Nullbyte am Schlu▀
  7167.         if (mconsp(Cdr(ThePathname(pathname)->pathname_directory)))
  7168.           { STACK_0 = O(null_string); }
  7169.           else
  7170.           { pushSTACK(O(null_string)); stringcount++; }
  7171.        {var reg2 object string = string_concat(stringcount); # zusammenhΣngen
  7172.         # Default-Directory Σndern:
  7173.         begin_system_call();
  7174.         if (!( chdir(TheAsciz(string)) ==0)) { OS_error(); }
  7175.         end_system_call();
  7176.       }}
  7177.       # Default-Drive neu setzen:
  7178.       O(default_drive) = ThePathname(STACK_0)->pathname_device;
  7179.       # *DEFAULT-PATHNAME-DEFAULTS* neu setzen:
  7180.       recalc_defaults_pathname();
  7181.     }
  7182. #endif
  7183. #ifdef PATHNAME_AMIGAOS
  7184. # UP: Setzt das Default-Directory neu.
  7185. # change_default();
  7186. # > STACK_0: absoluter Pathname, bei dem Directory kein :RELATIVE, :CURRENT,
  7187. #     :PARENT enthΣlt, und Name und Typ =NIL sind.
  7188. # kann GC ausl÷sen
  7189.   local void change_default (void);
  7190.   extern BPTR orig_dir_lock; # Lock auf das ursprⁿngliche Verzeichnis
  7191.                              # (das geh÷rt nicht uns, nicht freigeben!)
  7192.   local void change_default()
  7193.     { var reg3 uintC stringcount =
  7194.         directory_namestring_parts(STACK_0); # Strings fⁿrs Directory
  7195.       var reg2 object dir_namestring = string_concat(stringcount);
  7196.       dir_namestring = OSnamestring(dir_namestring); # Asciz, ohne ⁿberflⁿssigen '/' am Schlu▀
  7197.       # Default-Directory Σndern:
  7198.       set_break_sem_4();
  7199.       begin_system_call();
  7200.       {var reg1 BPTR lock = Lock(TheAsciz(dir_namestring),ACCESS_READ);
  7201.        if (lock==BPTR_NULL) { OS_error(); }
  7202.        lock = CurrentDir(lock); # current directory neu setzen
  7203.        # Lock zum alten current directory merken bzw. aufgeben:
  7204.        if (orig_dir_lock == BPTR_NONE)
  7205.          { orig_dir_lock = lock; }
  7206.          else
  7207.          { UnLock(lock); }
  7208.       }
  7209.       end_system_call();
  7210.       clr_break_sem_4();
  7211.     }
  7212. #endif
  7213. #ifdef PATHNAME_UNIX
  7214. # UP: Setzt das Default-Directory neu.
  7215. # change_default();
  7216. # > STACK_0: absoluter Pathname, bei dem Directory kein :RELATIVE, :CURRENT,
  7217. #     :PARENT enthΣlt, und Name und Typ =NIL sind.
  7218. # kann GC ausl÷sen
  7219.   local void change_default (void);
  7220.   local void change_default()
  7221.     { var reg2 uintC stringcount = host_namestring_parts(STACK_0); # Strings fⁿr den Host
  7222.       stringcount += directory_namestring_parts(STACK_0); # Strings fⁿrs Directory
  7223.       pushSTACK(O(null_string)); # und Nullbyte
  7224.      {var reg1 object string = string_concat(stringcount+1); # zusammenhΣngen
  7225.       # Default-Directory Σndern:
  7226.       begin_system_call();
  7227.       if (!( chdir(TheAsciz(string)) ==0)) { OS_error(); }
  7228.       end_system_call();
  7229.     }}
  7230. #endif
  7231. #ifdef PATHNAME_RISCOS
  7232. # UP: Setzt das Default-Directory neu.
  7233. # change_default();
  7234. # > STACK_0: absoluter Pathname, bei dem Name und Typ =NIL sind.
  7235. # kann GC ausl÷sen
  7236.   local void change_default (void);
  7237.   local void change_default()
  7238.     { var reg4 object pathname = STACK_0;
  7239.       var reg2 uintC stringcount = host_namestring_parts(pathname); # Strings fⁿr den Host
  7240.       stringcount += directory_namestring_parts(pathname); # Strings fⁿrs Directory
  7241.      {var reg1 object dir_namestring = string_concat(stringcount); # zusammenhΣngen
  7242.       var reg3 uintL len = TheSstring(dir_namestring)->length;
  7243.       ASSERT((len > 0) && (TheSstring(dir_namestring)->data[len-1]=='.'));
  7244.       TheSstring(dir_namestring)->data[len-1] = '\0'; # '.' am Schlu▀ durch Nullbyte ersetzen
  7245.       begin_system_call();
  7246.       if (!( chdir(TheAsciz(dir_namestring)) ==0)) { OS_error(); }
  7247.       end_system_call();
  7248.     }}
  7249. #endif
  7250.  
  7251. LISPFUN(namestring,1,1,norest,nokey,0,NIL)
  7252. # (NAMESTRING pathname), CLTL S. 417
  7253. # (NAMESTRING pathname t) -> Namestring im externen Format
  7254. #   GEMDOS: ohne Seriennummer, mit Default-Directory
  7255. #   Unix: mit Default-Directory
  7256.   { var reg2 object flag = popSTACK(); # optionales Argument flag
  7257.     var reg1 object pathname = coerce_pathname(popSTACK()); # Argument zu einem Pathname machen
  7258.     #if defined(PATHNAME_ATARI) || defined(PATHNAME_UNIX) || defined(PATHNAME_AMIGAOS) || defined(PATHNAME_RISCOS)
  7259.     if (!eq(flag,unbound) && !nullp(flag))
  7260.       # flag /= NIL -> fⁿrs Betriebssystem:
  7261.       { check_no_wildcards(pathname); # mit Wildcards -> Fehler
  7262.         pathname = use_default_dir(pathname); # Default-Directory einfⁿgen
  7263.         # (da GEMDOS/Unix/AMIGAOS das Default-Directory von LISP nicht kennt)
  7264.         #ifdef PATHNAME_ATARI
  7265.         {var reg2 uintC stringcount;
  7266.          stringcount = directory_namestring_parts(pathname,TRUE); # Strings fⁿrs Directory
  7267.          stringcount += file_namestring_parts(pathname); # Strings fⁿr den Filename
  7268.          value1 = string_concat(stringcount); # zusammenhΣngen
  7269.         }
  7270.         #else
  7271.         value1 = whole_namestring(pathname);
  7272.         #endif
  7273.       }
  7274.       else
  7275.     #endif
  7276.       # normal
  7277.       { value1 = whole_namestring(pathname); }
  7278.     mv_count=1;
  7279.   }
  7280.  
  7281. # Fehlermeldung wegen fehlendem Dateinamen
  7282. # fehler_noname(pathname);
  7283. # > pathname: Pathname
  7284.   nonreturning_function(local, fehler_noname, (object pathname));
  7285.   local void fehler_noname(pathname)
  7286.     var reg1 object pathname;
  7287.     { pushSTACK(pathname); # Wert fⁿr Slot PATHNAME von FILE-ERROR
  7288.       pushSTACK(pathname);
  7289.       fehler(file_error,
  7290.              DEUTSCH ? "Dateiname mu▀ angegeben werden: ~" :
  7291.              ENGLISH ? "no file name given: ~" :
  7292.              FRANCAIS ? "Un nom de fichier doit Ωtre fourni : ~" :
  7293.              ""
  7294.             );
  7295.     }
  7296.  
  7297. # Test, ob ein File existiert:
  7298. # if_file_exists(namestring,statement1,statement2);
  7299. # > vorausgegangen: assure_dir_exists()
  7300. # > im STACK: Pathname, wie nach Ausfⁿhrung von assure_dir_exists(), Name/=NIL
  7301. # > namestring: dessen Namestring als ASCIZ-String
  7302. # Falls das File existiert, wird statement1 ausgefⁿhrt, sonst statement2.
  7303.   #ifdef ATARI
  7304.     #define if_file_exists(namestring,statement1,statement2)  \
  7305.       {{var reg2 sintW errorcode;                                               \
  7306.         errorcode = # Datei zu ÷ffnen versuchen, Modus 0 (Read)                 \
  7307.           GEMDOS_open(TheAsciz(namestring),0);                                  \
  7308.         if (errorcode == GEMDOS_open_NotFound) # nicht gefunden?                \
  7309.           goto not_exists;                                                      \
  7310.         if (errorcode < 0) { OS_error(errorcode); } # sonstigen Error melden   \
  7311.         # Nun enthΣlt errorcode das Handle des ge÷ffneten Files.                \
  7312.         errorcode = # Datei gleich wieder schlie▀en                             \
  7313.           GEMDOS_close(errorcode);                                              \
  7314.         if (errorcode < 0) { OS_error(errorcode); } # Error melden             \
  7315.        }                                                                        \
  7316.        if (TRUE) { statement1; } else { not_exists: statement2; }               \
  7317.       }
  7318.   #else
  7319.     #define if_file_exists(namestring,statement1,statement2)  \
  7320.       { if (file_exists(namestring)) { statement1; } else { statement2; } }
  7321.     #ifdef MSDOS
  7322.       local int access0 (CONST char* path);
  7323.       local int access0(path)
  7324.         var reg2 CONST char* path;
  7325.         { var reg1 int erg;
  7326.           begin_system_call();
  7327.           erg = access(path,0);
  7328.           end_system_call();
  7329.           return erg;
  7330.         }
  7331.       #define file_exists(namestring)  (access0(TheAsciz(namestring))==0)
  7332.     #endif
  7333.     #ifdef AMIGAOS
  7334.       #define file_exists(namestring)  (!(filestatus == (struct FileInfoBlock *)NULL))
  7335.     #endif
  7336.     #if defined(UNIX) || defined(RISCOS)
  7337.       #define file_exists(namestring)  (!(filestatus == (struct stat *)NULL))
  7338.     #endif
  7339.   #endif
  7340.  
  7341. # Fehlermeldung wegen nicht existenter Datei
  7342. # fehler_file_not_exists();
  7343. # > STACK_0: Pathname
  7344. # > subr_self: Aufrufer (ein SUBR)
  7345.   nonreturning_function(local, fehler_file_not_exists, (void));
  7346.   local void fehler_file_not_exists()
  7347.     { # STACK_0 = Wert fⁿr Slot PATHNAME von FILE-ERROR
  7348.       pushSTACK(STACK_0); # pathname
  7349.       pushSTACK(TheSubr(subr_self)->name);
  7350.       fehler(file_error,
  7351.              DEUTSCH ? "~: Datei ~ existiert nicht." :
  7352.              ENGLISH ? "~: file ~ does not exist" :
  7353.              FRANCAIS ? "~ : Le fichier ~ n'existe pas." :
  7354.              ""
  7355.             );
  7356.     }
  7357.  
  7358. LISPFUNN(truename,1)
  7359. # (TRUENAME pathname), CLTL S. 413
  7360.   { var reg1 object pathname = popSTACK(); # pathname-Argument
  7361.     if (streamp(pathname))
  7362.       # Stream -> extra behandeln:
  7363.       { # mu▀ File-Stream sein:
  7364.         pathname = as_file_stream(pathname);
  7365.         # Streamtyp File-Stream
  7366.         value1 = TheStream(pathname)->strm_file_truename;
  7367.       }
  7368.       else
  7369.       { pathname = coerce_pathname(pathname); # zu einem Pathname machen
  7370.         check_no_wildcards(pathname); # mit Wildcards -> Fehler
  7371.         pathname = use_default_dir(pathname); # Default-Directory einfⁿgen
  7372.         pushSTACK(pathname);
  7373.        {# Directory mu▀ existieren:
  7374.         var reg3 object namestring = assure_dir_exists(FALSE); # Filename als ASCIZ-String
  7375.         if (namenullp(STACK_0))
  7376.           # Kein Name angegeben
  7377.           { if (!nullp(ThePathname(STACK_0)->pathname_type))
  7378.               { # STACK_0 = Wert fⁿr Slot PATHNAME von FILE-ERROR
  7379.                 pushSTACK(STACK_0); # pathname
  7380.                 pushSTACK(TheSubr(subr_self)->name);
  7381.                 fehler(file_error,
  7382.                        DEUTSCH ? "~: Pathname mit TYPE, aber ohne NAME sinnlos: ~" :
  7383.                        ENGLISH ? "~: pathname with type but without name makes no sense: ~" :
  7384.                        FRANCAIS ? "~ : Un PATHNAME avec TYPE mais sans NAME est insensΘ: ~" :
  7385.                        ""
  7386.                       );
  7387.               }
  7388.             # Kein Name und kein Typ angegeben -> pathname als Ergebnis
  7389.           }
  7390.           else
  7391.           # Name angegeben.
  7392.           { # ▄berprⁿfe, ob die Datei existiert:
  7393.             if_file_exists(namestring, ; , { fehler_file_not_exists(); } );
  7394.             # Datei existiert -> Pathname als Wert
  7395.           }
  7396.         value1 = popSTACK();
  7397.       }}
  7398.     mv_count=1;
  7399.   }
  7400.  
  7401. LISPFUNN(probe_file,1)
  7402. # (PROBE-FILE filename), CLTL S. 424
  7403.   { var reg1 object pathname = popSTACK(); # pathname-Argument
  7404.     if (streamp(pathname))
  7405.       # Stream -> extra behandeln:
  7406.       { # mu▀ File-Stream sein:
  7407.         pathname = as_file_stream(pathname);
  7408.         # Streamtyp File-Stream -> Truename nehmen:
  7409.        {var reg1 uintB flags = TheStream(pathname)->strmflags;
  7410.         pathname = TheStream(pathname)->strm_file_truename;
  7411.         if (flags & strmflags_open_B) # Datei ge÷ffnet ?
  7412.           # ja -> Truename sofort als Ergebnis:
  7413.           { value1 = pathname; mv_count=1; return; }
  7414.         # nein -> noch testen, ob die Datei zum Truename existiert.
  7415.       }}
  7416.       else
  7417.       { pathname = coerce_pathname(pathname); } # zu einem Pathname machen
  7418.     # pathname ist jetzt ein Pathname.
  7419.     check_no_wildcards(pathname); # mit Wildcards -> Fehler
  7420.     pathname = use_default_dir(pathname); # Default-Directory einfⁿgen
  7421.     if (namenullp(pathname)) { fehler_noname(pathname); } # Kein Name angegeben -> Fehler
  7422.     # Name angegeben.
  7423.     pushSTACK(pathname);
  7424.    {# Directory mu▀ existieren:
  7425.     var reg3 object namestring = assure_dir_exists(TRUE); # Filename als ASCIZ-String
  7426.     if (eq(namestring,nullobj))
  7427.       # Pfad zur Datei existiert nicht -> NIL als Wert:
  7428.       { skipSTACK(1); value1 = NIL; mv_count=1; return; }
  7429.     # ▄berprⁿfe, ob die Datei existiert:
  7430.     if_file_exists(namestring,
  7431.       { value1 = popSTACK(); mv_count=1; }, # Datei existiert -> Pathname als Wert
  7432.       { skipSTACK(1); value1 = NIL; mv_count=1; return; } # sonst NIL als Wert
  7433.       );
  7434.   }}
  7435.  
  7436. # UP: Stellt fest, ob eine Datei ge÷ffnet ist.
  7437. # openp(pathname)
  7438. #if defined(PATHNAME_ATARI) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  7439. # > pathname: absoluter Pathname, ohne Wildcards.
  7440. #endif
  7441. #ifdef PATHNAME_AMIGAOS
  7442. # > pathname: absoluter Pathname, ohne Wildcards, ohne :PARENT
  7443. #endif
  7444. #ifdef PATHNAME_UNIX
  7445. # > pathname: absoluter Pathname, ohne Wildcards, nach Aufl÷sung
  7446. #             symbolischer Links
  7447. #endif
  7448. # < ergebnis: TRUE, falls ein ge÷ffneter File-Stream auf diese Datei existiert.
  7449.   local boolean openp (object pathname);
  7450.   local boolean openp(pathname)
  7451.     var reg2 object pathname;
  7452.     { var reg1 object flist = O(open_files); # Liste aller offenen Files durchlaufen
  7453.       while (consp(flist))
  7454.         { var reg3 object f = Car(flist); # nΣchster offener Stream
  7455.           if_strm_file_p(f, # File-Stream ?
  7456.             { if (equal(TheStream(f)->strm_file_truename,pathname))
  7457.                 { return TRUE; }
  7458.             },
  7459.             ; );
  7460.           flist = Cdr(flist);
  7461.         }
  7462.       return FALSE;
  7463.     }
  7464.  
  7465. # Fehlermeldung wegen L÷schversuch auf ge÷ffnete Datei
  7466. # fehler_delete_open(pathname);
  7467. # > pathname: Truename der Datei
  7468.   nonreturning_function(local, fehler_delete_open, (object pathname));
  7469.   local void fehler_delete_open(pathname)
  7470.     var reg1 object pathname;
  7471.     { pushSTACK(pathname); # Wert fⁿr Slot PATHNAME von FILE-ERROR
  7472.       pushSTACK(pathname);
  7473.       fehler(file_error,
  7474.              DEUTSCH ? "Datei ~ kann nicht gel÷scht werden, weil ein File-Stream auf sie ge÷ffnet wurde." :
  7475.              ENGLISH ? "cannot delete file ~ since there is file stream open to it" :
  7476.              FRANCAIS ? "Le fichier ~ ne peut pas Ωtre effacΘ car il est encore ouvert comme ½stream╗." :
  7477.              ""
  7478.             );
  7479.     }
  7480.  
  7481. LISPFUNN(delete_file,1)
  7482. # (DELETE-FILE filename), CLTL S. 424
  7483.   { var reg1 object pathname = popSTACK(); # pathname-Argument
  7484.     if (streamp(pathname))
  7485.       # Stream -> extra behandeln:
  7486.       { var object stream = as_file_stream(pathname); # mu▀ File-Stream sein
  7487.         # Streamtyp File-Stream.
  7488.         # Falls Datei ge÷ffnet, erst Datei schlie▀en:
  7489.         if (TheStream(stream)->strmflags & strmflags_open_B) # Datei ge÷ffnet ?
  7490.           { stream_close(&stream); }
  7491.         # Dann den Truename als zu l÷schende Datei nehmen:
  7492.         pathname = TheStream(stream)->strm_file_truename;
  7493.       }
  7494.       else
  7495.       { pathname = coerce_pathname(pathname); } # zu einem Pathname machen
  7496.     # pathname ist jetzt ein Pathname.
  7497.     check_no_wildcards(pathname); # mit Wildcards -> Fehler
  7498.     pathname = use_default_dir(pathname); # Default-Directory einfⁿgen
  7499.     if (namenullp(pathname)) { fehler_noname(pathname); } # Kein Name angegeben -> Fehler
  7500.     # Name angegeben.
  7501.     pushSTACK(pathname);
  7502.    {# Directory mu▀ existieren:
  7503.     var reg3 object namestring = assure_dir_exists(TRUE); # Filename als ASCIZ-String
  7504.     if (eq(namestring,nullobj))
  7505.       # Pfad zur Datei existiert nicht -> Wert NIL
  7506.       { skipSTACK(1); value1 = NIL; mv_count=1; return; }
  7507.     if (openp(STACK_0)) { fehler_delete_open(STACK_0); } # Keine offenen Dateien l÷schen!
  7508.     # Datei l÷schen:
  7509.     #ifdef ATARI
  7510.     {var reg2 sintW errorcode;
  7511.      errorcode = # Datei zu l÷schen versuchen
  7512.        GEMDOS_unlink(TheAsciz(namestring));
  7513.      if (errorcode == GEMDOS_open_NotFound) # nicht gefunden -> Wert NIL
  7514.        { skipSTACK(1); value1 = NIL; mv_count=1; return; }
  7515.      if (errorcode < 0) { OS_error(errorcode); } # sonstigen Error melden
  7516.     }
  7517.     #endif
  7518.     #ifdef AMIGAOS
  7519.     if (!file_exists(namestring))
  7520.       { skipSTACK(1); value1 = NIL; mv_count=1; return; } # File existiert nicht -> Wert NIL
  7521.     begin_system_call();
  7522.     if (! DeleteFile(TheAsciz(namestring)) ) { OS_error(); }
  7523.     end_system_call();
  7524.     #endif
  7525.     #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS)
  7526.     begin_system_call();
  7527.     if (!( unlink(TheAsciz(namestring)) ==0))
  7528.       { if (!(errno==ENOENT)) { OS_error(); }
  7529.         end_system_call();
  7530.         # File existiert nicht -> Wert NIL
  7531.         skipSTACK(1); value1 = NIL; mv_count=1; return;
  7532.       }
  7533.     end_system_call();
  7534.     #endif
  7535.     # Datei existierte, wurde gel÷scht -> Pathname (/=NIL) als Wert
  7536.     value1 = popSTACK(); mv_count=1;
  7537.   }}
  7538.  
  7539. # Fehlermeldung wegen Umbenennungsversuch einer ge÷ffneten Datei
  7540. # fehler_rename_open(pathname);
  7541. # > pathname: Truename der Datei
  7542.   nonreturning_function(local, fehler_rename_open, (object pathname));
  7543.   local void fehler_rename_open(pathname)
  7544.     var reg1 object pathname;
  7545.     { pushSTACK(pathname); # Wert fⁿr Slot PATHNAME von FILE-ERROR
  7546.       pushSTACK(pathname);
  7547.       fehler(file_error,
  7548.              DEUTSCH ? "Datei ~ kann nicht umbenannt werden, weil ein File-Stream auf sie ge÷ffnet wurde." :
  7549.              ENGLISH ? "cannot rename file ~ since there is file stream open to it" :
  7550.              FRANCAIS ? "Le fichier ~ ne peut pas Ωtre renommΘ car il est encore ouvert comme ½stream╗." :
  7551.              ""
  7552.             );
  7553.     }
  7554.  
  7555. # UP: Fⁿhrt eine Datei-Umbenennung durch.
  7556. # rename_file();
  7557. # > Stackaufbau: filename, newname, oldpathname.
  7558. # < Stackaufbau: filename, newname, oldpathname, newpathname,
  7559. #                oldtruename, oldnamestring, newtruename, newnamestring.
  7560.   local void rename_file (void);
  7561.   local void rename_file()
  7562.     { # 1. newpathname := (MERGE-PATHNAMES newname oldpathname)
  7563.       { pushSTACK(STACK_1); # newname als 1. Argument
  7564.         pushSTACK(STACK_(0+1)); # oldpathname als 2. Argument
  7565.         funcall(L(merge_pathnames),2);
  7566.         pushSTACK(value1);
  7567.       }
  7568.       # Stackaufbau: filename, newname, oldpathname, newpathname.
  7569.       # 2. oldpathname ⁿberprⁿfen:
  7570.       { var reg1 object oldpathname = STACK_1;
  7571.         check_no_wildcards(oldpathname); # mit Wildcards -> Fehler
  7572.         oldpathname = use_default_dir(oldpathname); # Default-Directory einfⁿgen
  7573.         if (namenullp(oldpathname)) { fehler_noname(oldpathname); } # Kein Name angegeben -> Fehler
  7574.         # Name angegeben.
  7575.         pushSTACK(oldpathname);
  7576.        {# Directory mu▀ existieren:
  7577.         var reg2 object old_namestring = assure_dir_exists(FALSE); # Filename als ASCIZ-String
  7578.         if (openp(STACK_0)) { fehler_rename_open(STACK_0); } # Keine offenen Dateien umbenennen!
  7579.         pushSTACK(old_namestring);
  7580.       }}
  7581.       # Stackaufbau: filename, newname, oldpathname, newpathname,
  7582.       #              oldtruename, oldnamestring.
  7583.       # 3. newpathname ⁿberprⁿfen:
  7584.       { var reg1 object newpathname = coerce_pathname(STACK_2);
  7585.         check_no_wildcards(newpathname); # mit Wildcards -> Fehler
  7586.         newpathname = use_default_dir(newpathname); # Default-Directory einfⁿgen
  7587.         if (namenullp(newpathname)) { fehler_noname(newpathname); } # Kein Name angegeben -> Fehler
  7588.         # Name angegeben.
  7589.         pushSTACK(newpathname);
  7590.        {# Directory mu▀ existieren:
  7591.         var reg2 object new_namestring = assure_dir_exists(FALSE); # Filename als ASCIZ-String
  7592.         pushSTACK(new_namestring);
  7593.       }}
  7594.       # Stackaufbau: filename, newname, oldpathname, newpathname,
  7595.       #              oldtruename, oldnamestring, newtruename, newnamestring.
  7596.       # 4. Datei umbenennen:
  7597.       #ifdef ATARI
  7598.       {var reg1 sintW errorcode;
  7599.        errorcode = # Datei umzubenennen versuchen
  7600.          GEMDOS_rename(TheAsciz(STACK_2),TheAsciz(STACK_0));
  7601.        if (errorcode == GEMDOS_rename_exists) # 'Zugriff verweigert' ?
  7602.          # ja -> Datei existiert bereits
  7603.          { fehler_file_exists(S(rename_file),STACK_1); }
  7604.        if (errorcode < 0) { OS_error(errorcode); } # sonstigen Error melden
  7605.       }
  7606.       #endif
  7607.       #if defined(UNIX) || defined(AMIGAOS) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS)
  7608.       if (file_exists(STACK_0))
  7609.         # Datei existiert bereits -> nicht ohne Vorwarnung l÷schen
  7610.         { fehler_file_exists(S(rename_file),STACK_1); }
  7611.       # Nun kann gefahrlos umbenannt werden:
  7612.       #ifdef PATHNAME_RISCOS
  7613.       prepare_create(STACK_4);
  7614.       #endif
  7615.       begin_system_call();
  7616.       #ifdef AMIGAOS
  7617.       if (! Rename(TheAsciz(STACK_2),TheAsciz(STACK_0)) ) { OS_error(); }
  7618.       #endif
  7619.       #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS)
  7620.       if (!( rename(TheAsciz(STACK_2),TheAsciz(STACK_0)) ==0))
  7621.         { OS_error(); }
  7622.       #endif
  7623.       end_system_call();
  7624.       #endif
  7625.     }
  7626.  
  7627. LISPFUNN(rename_file,2)
  7628. # (RENAME-FILE filename newname), CLTL S. 423
  7629.   { var reg1 object filename = STACK_1; # filename-Argument
  7630.     if (streamp(filename))
  7631.       # Stream -> extra behandeln:
  7632.       { # mu▀ File-Stream sein:
  7633.         filename = as_file_stream(filename);
  7634.         # Streamtyp File-Stream -> Truename verwenden:
  7635.         filename = TheStream(filename)->strm_file_truename;
  7636.         pushSTACK(filename);
  7637.         # Umbenennen:
  7638.         rename_file();
  7639.         # Stream aktualisieren:
  7640.         filename = STACK_7;
  7641.         TheStream(filename)->strm_file_name = STACK_4; # newpathname als neuer Name
  7642.         TheStream(filename)->strm_file_truename = STACK_1; # newtruename als neuer Truename
  7643.         # Handle etc. unverΣndert lassen
  7644.       }
  7645.       else
  7646.       { filename = coerce_pathname(filename); # zu einem Pathname machen
  7647.         pushSTACK(filename);
  7648.         # Umbenennen:
  7649.         rename_file();
  7650.       }
  7651.     value1 = STACK_4; # newpathname als 1. Wert
  7652.     value2 = STACK_3; # oldtruename als 2. Wert
  7653.     value3 = STACK_1; # newtruename als 3. Wert
  7654.     mv_count=3; skipSTACK(8); # 3 Werte
  7655.   }
  7656.  
  7657. # UP: erzeugt ein File-Stream
  7658. # open_file(filename,direction,if_exists,if_not_exists,type,eltype_size)
  7659. # > filename: Filename, ein Pathname
  7660. # > direction: Modus (0 = :PROBE, 1 = :INPUT, 4 = :OUTPUT, 5 = :IO, 3 = :INPUT-IMMUTABLE)
  7661. # > if_exists: :IF-EXISTS-Argument
  7662. #         (0 = nichts, 1 = :ERROR, 2 = NIL,
  7663. #          3 = :RENAME, 4 = :RENAME-AND-DELETE, 5 = :NEW-VERSION,:SUPERSEDE,
  7664. #          6 = :APPEND, 7 = :OVERWRITE)
  7665. # > if_not_exists: :IF-DOES-NOT-EXIST-Argument
  7666. #         (0 = nichts, 1 = :ERROR, 2 = NIL, 3 = :CREATE)
  7667. # > type: nΣhere Typinfo
  7668. #         (STRMTYPE_SCH_FILE oder STRMTYPE_CH_FILE oder
  7669. #          STRMTYPE_IU_FILE oder STRMTYPE_IS_FILE)
  7670. # > eltype_size: (bei Integer-Streams) Gr÷▀e der Elemente in Bits,
  7671. #         ein Fixnum >0 und <intDsize*uintC_max
  7672. # < ergebnis: Stream oder NIL
  7673. # kann GC ausl÷sen
  7674.   local object open_file (object filename, uintB direction, uintB if_exists, uintB if_not_exists,
  7675.                           uintB type, object eltype_size);
  7676.   local object open_file(filename,direction,if_exists,if_not_exists,type,eltype_size)
  7677.     var reg5 object filename;
  7678.     var reg8 uintB direction;
  7679.     var reg3 uintB if_exists;
  7680.     var reg4 uintB if_not_exists;
  7681.     var reg7 uintB type;
  7682.     var reg9 object eltype_size;
  7683.     { pushSTACK(filename); # Filename retten
  7684.       check_no_wildcards(filename); # mit Wildcards -> Fehler
  7685.       filename = use_default_dir(filename); # Default-Directory einfⁿgen
  7686.       if (namenullp(filename)) { fehler_noname(filename); } # Kein Name angegeben -> Fehler
  7687.       pushSTACK(filename); # absPathname retten
  7688.       # Stackaufbau: Pathname, absPathname.
  7689.       { # Directory mu▀ existieren:
  7690.         var reg3 object namestring = # Filename als ASCIZ-String
  7691.           assure_dir_exists((direction == 0) && ((if_not_exists % 2) == 0)); # tolerant nur bei :PROBE und if_not_exists = 0 oder 2
  7692.         # Stackaufbau: Pathname, Truename.
  7693.         # Filename ⁿberprⁿfen und Handle holen:
  7694.         var reg2 object handle;
  7695.         var reg6 boolean append_flag = FALSE;
  7696.         switch (direction)
  7697.           { case 0: # Modus ist :PROBE
  7698.               if (eq(namestring,nullobj))
  7699.                 # Pfad zur Datei existiert nicht, und :IF-DOES-NOT-EXIST = nichts oder NIL
  7700.                 goto ergebnis_NIL;
  7701.               #ifdef ATARI
  7702.               { # erst mit GEMDOS_open erfragen, ob die Datei existiert:
  7703.                 var reg1 sintW errorcode;
  7704.                 errorcode = # Datei zu ÷ffnen versuchen, Modus 0 (Read)
  7705.                   GEMDOS_open(TheAsciz(namestring),0);
  7706.                 if (errorcode == GEMDOS_open_NotFound) # nicht gefunden?
  7707.                   # Datei existiert nicht
  7708.                   { # :IF-DOES-NOT-EXIST-Argument entscheidet:
  7709.                     if (if_not_exists==1) # :ERROR -> Error
  7710.                       goto fehler_notfound;
  7711.                     if (!(if_not_exists==3)) # nichts oder NIL -> NIL
  7712.                       goto ergebnis_NIL;
  7713.                     # :CREATE -> Datei mit GEMDOS_create erzeugen (Attribute=0) und schlie▀en:
  7714.                     errorcode = GEMDOS_create(TheAsciz(namestring),0);
  7715.                   }
  7716.                 if (errorcode<0) { OS_error(errorcode); } # sonstigen Error melden
  7717.                 # Datei existiert, errorcode ist das Handle
  7718.                 # Datei wieder schlie▀en:
  7719.                 errorcode = GEMDOS_close(errorcode);
  7720.                 if (errorcode<0) { OS_error(errorcode); } # Error melden
  7721.                 handle = NIL; # Handle := NIL
  7722.                 break;
  7723.               }
  7724.               #endif
  7725.               #if defined(UNIX) || defined(AMIGAOS) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS)
  7726.               if (!file_exists(namestring))
  7727.                 # Datei existiert nicht
  7728.                 { # :IF-DOES-NOT-EXIST-Argument entscheidet:
  7729.                   if (if_not_exists==1) # :ERROR -> Error
  7730.                     goto fehler_notfound;
  7731.                   if (!(if_not_exists==3)) # nichts oder NIL -> NIL
  7732.                     goto ergebnis_NIL;
  7733.                   #ifdef PATHNAME_RISCOS
  7734.                   pushSTACK(namestring); prepare_create(STACK_1); namestring = popSTACK();
  7735.                   #endif
  7736.                  {# :CREATE -> Datei mit open erzeugen und schlie▀en:
  7737.                   #ifdef AMIGAOS
  7738.                   var reg1 Handle handle;
  7739.                   begin_system_call();
  7740.                   handle = Open(TheAsciz(namestring),MODE_NEWFILE);
  7741.                   if (handle == Handle_NULL) { OS_error(); } # Error melden
  7742.                   # Datei wurde erzeugt, handle ist das Handle.
  7743.                   # Datei wieder schlie▀en:
  7744.                   (void) Close(handle);
  7745.                   end_system_call();
  7746.                   #endif
  7747.                   #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS)
  7748.                   var reg1 int ergebnis;
  7749.                   begin_system_call();
  7750.                   #if defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM)
  7751.                   ergebnis = creat(TheAsciz(namestring),my_open_mask);
  7752.                   if (ergebnis<0) { OS_error(); } # Error melden
  7753.                   setmode(ergebnis,O_BINARY);
  7754.                   #endif
  7755.                   #if defined(UNIX) || defined(RISCOS)
  7756.                   ergebnis = OPEN(TheAsciz(namestring),
  7757.                                   O_WRONLY | O_CREAT | O_TRUNC,
  7758.                                   my_open_mask
  7759.                                  );
  7760.                   if (ergebnis<0) { OS_error(); } # Error melden
  7761.                   #endif
  7762.                   # Datei wurde erzeugt, ergebnis ist das Handle.
  7763.                   # Datei wieder schlie▀en:
  7764.                   ergebnis = CLOSE(ergebnis);
  7765.                   if (!(ergebnis==0)) { OS_error(); } # Error melden
  7766.                   end_system_call();
  7767.                   #endif
  7768.                 }}
  7769.               handle = NIL; # Handle := NIL
  7770.               break;
  7771.               #endif
  7772.             case 1: case 3: # Modus ist :INPUT
  7773.               #ifdef ATARI
  7774.               { # erst mit GEMDOS_open erfragen, ob die Datei existiert:
  7775.                 var reg1 sintW errorcode;
  7776.                 errorcode = # Datei zu ÷ffnen versuchen, Modus 0 (Read)
  7777.                   GEMDOS_open(TheAsciz(namestring),0);
  7778.                 if (errorcode == GEMDOS_open_NotFound) # nicht gefunden?
  7779.                   # Datei existiert nicht
  7780.                   { # :IF-DOES-NOT-EXIST-Argument entscheidet:
  7781.                     if (if_not_exists==2) # NIL -> NIL
  7782.                       goto ergebnis_NIL;
  7783.                     if (!(if_not_exists==3)) # nichts oder :ERROR -> Error
  7784.                       goto fehler_notfound;
  7785.                     # :CREATE -> Datei mit GEMDOS_create erzeugen (Attribute=0):
  7786.                     errorcode = GEMDOS_create(TheAsciz(namestring),0);
  7787.                   }
  7788.                 if (errorcode<0) { OS_error(errorcode); } # sonstigen Error melden
  7789.                 # Datei existiert, errorcode ist das Handle
  7790.                 handle = allocate_handle(errorcode); # Handle
  7791.                 break;
  7792.               }
  7793.               #endif
  7794.               #if defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM)
  7795.               { # erst mit open erfragen, ob die Datei existiert:
  7796.                 var reg1 sintW ergebnis;
  7797.                 # Datei zu ÷ffnen versuchen:
  7798.                 begin_system_call();
  7799.                 ergebnis = open(TheAsciz(namestring),O_RDONLY);
  7800.                 if (ergebnis<0)
  7801.                   { if (errno == ENOENT) # nicht gefunden?
  7802.                       # Datei existiert nicht
  7803.                       { # :IF-DOES-NOT-EXIST-Argument entscheidet:
  7804.                         if (if_not_exists==2) # NIL -> NIL
  7805.                           goto ergebnis_NIL;
  7806.                         if (!(if_not_exists==3)) # nichts oder :ERROR -> Error
  7807.                           goto fehler_notfound;
  7808.                         # :CREATE -> Datei mit creat erzeugen:
  7809.                         ergebnis = creat(TheAsciz(namestring),my_open_mask);
  7810.                         if (ergebnis<0) { OS_error(); }
  7811.                       }
  7812.                       else
  7813.                       { OS_error(); } # sonstigen Error melden
  7814.                   }
  7815.                 setmode(ergebnis,O_BINARY);
  7816.                 end_system_call();
  7817.                 # Datei existiert, ergebnis ist das Handle
  7818.                 handle = allocate_handle(ergebnis); # Handle
  7819.                 break;
  7820.               }
  7821.               #endif
  7822.               #ifdef AMIGAOS
  7823.               { # erst mit Open erfragen, ob die Datei existiert:
  7824.                 var reg1 Handle handl;
  7825.                 begin_system_call();
  7826.                 handl = Open(TheAsciz(namestring),MODE_OLDFILE);
  7827.                 if (handl==Handle_NULL)
  7828.                   { if (IoErr()==ERROR_OBJECT_NOT_FOUND)
  7829.                       # Datei existiert nicht
  7830.                       { # :IF-DOES-NOT-EXIST-Argument entscheidet:
  7831.                         if (if_not_exists==2) # NIL -> NIL
  7832.                           goto ergebnis_NIL;
  7833.                         if (!(if_not_exists==3)) # nichts oder :ERROR -> Error
  7834.                           goto fehler_notfound;
  7835.                         # :CREATE -> Datei mit Open erzeugen:
  7836.                         handl = Open(TheAsciz(namestring),MODE_READWRITE);
  7837.                   }   }
  7838.                 if (handl==Handle_NULL) { OS_error(); } # Error melden
  7839.                 end_system_call();
  7840.                 # Datei existiert, handle ist das Handle
  7841.                 handle = allocate_handle(handl); # Handle als Lisp-Objekt
  7842.                 break;
  7843.               }
  7844.               #endif
  7845.               #if defined(UNIX) || defined(RISCOS)
  7846.               { var reg2 int o_flags = O_RDONLY;
  7847.                 if (!file_exists(namestring))
  7848.                   # Datei existiert nicht
  7849.                   { # :IF-DOES-NOT-EXIST-Argument entscheidet:
  7850.                     if (if_not_exists==2) # NIL -> NIL
  7851.                       goto ergebnis_NIL;
  7852.                     if (!(if_not_exists==3)) # nichts oder :ERROR -> Error
  7853.                       goto fehler_notfound;
  7854.                     # :CREATE -> Datei mit open erzeugen
  7855.                     #ifdef PATHNAME_RISCOS
  7856.                     pushSTACK(namestring); prepare_create(STACK_1); namestring = popSTACK();
  7857.                     #endif
  7858.                     o_flags |= O_CREAT;
  7859.                   }
  7860.                {var reg1 int ergebnis;
  7861.                 begin_system_call();
  7862.                 ergebnis = OPEN(TheAsciz(namestring),
  7863.                                 o_flags, # O_RDONLY bzw. O_RDONLY | O_CREAT
  7864.                                 my_open_mask
  7865.                                );
  7866.                 if (ergebnis<0) { OS_error(); } # Error melden
  7867.                 end_system_call();
  7868.                 # Datei existiert, ergebnis ist das Handle
  7869.                 handle = allocate_handle(ergebnis); # Handle
  7870.               }}
  7871.               break;
  7872.               #endif
  7873.             default: # Modus ist :OUTPUT oder :IO
  7874.               { # Defaultwert fⁿr if_not_exists ist von if_exists abhΣngig:
  7875.                 if (if_not_exists==0) # falls if_not_exists nicht angegeben:
  7876.                   { if (if_exists<6) # if_exists = :APPEND oder :OVERWRITE -> if_not_exists unverΣndert
  7877.                       { if_not_exists = 3; } # weder :APPEND noch :OVERWRITE -> Default ist :CREATE
  7878.                   }
  7879.                 # Defaultwert fⁿr if_exists ist :NEW-VERSION :
  7880.                 if (if_exists==0) { if_exists = 5; }
  7881.                 #ifdef ATARI
  7882.                 # Bei if_exists=5 und if_not_exists=3 kann man sofort
  7883.                 # CREATE ansteuern, sonst mu▀ man vorher OPEN versuchen:
  7884.                 if (!((if_exists==5) && (if_not_exists==3)))
  7885.                   { var reg1 sintW errorcode;
  7886.                     errorcode = # Datei zu ÷ffnen versuchen, Modus 2 (Read/Write)
  7887.                       GEMDOS_open(TheAsciz(namestring),2);
  7888.                     if (errorcode == GEMDOS_open_NotFound) # nicht gefunden?
  7889.                       # Datei existiert nicht
  7890.                       { # :IF-DOES-NOT-EXIST-Argument entscheidet:
  7891.                         if (if_not_exists<2) # (Default bei :APPEND oder :OVERWRITE) oder :ERROR ?
  7892.                           goto fehler_notfound;
  7893.                         if (if_not_exists==2) # NIL -> NIL
  7894.                           goto ergebnis_NIL;
  7895.                         # :CREATE
  7896.                       }
  7897.                       else
  7898.                       if (errorcode<0) { OS_error(errorcode); } # sonstigen Error melden
  7899.                       else
  7900.                       # Datei existiert, errorcode ist das Handle
  7901.                       { # :IF-EXISTS-Argument entscheidet:
  7902.                         switch (if_exists)
  7903.                           { case 1: # :ERROR -> schlie▀en und Error
  7904.                               { errorcode = GEMDOS_close(errorcode);
  7905.                                 if (errorcode<0) { OS_error(errorcode); } # Error melden
  7906.                                 goto fehler_exists;
  7907.                               }
  7908.                             case 2: # NIL -> schlie▀en und NIL
  7909.                               { errorcode = GEMDOS_close(errorcode);
  7910.                                 if (errorcode<0) { OS_error(errorcode); } # Error melden
  7911.                                 goto ergebnis_NIL;
  7912.                               }
  7913.                             case 6: # :APPEND
  7914.                               append_flag = TRUE; # am Schlu▀ ans Ende positionieren
  7915.                             case 7: # :OVERWRITE -> bestehende Datei benutzen
  7916.                               handle = allocate_handle(errorcode);
  7917.                               goto handle_ok;
  7918.                             default: ;
  7919.                               # :RENAME, :RENAME-AND-DELETE -> Datei umbenennen und dann neu er÷ffnen.
  7920.                               # :NEW-VERSION, :SUPERSEDE -> Datei auf LΣnge 0 kⁿrzen.
  7921.                           }
  7922.                         # In beiden FΣllen erst die Datei schlie▀en:
  7923.                         errorcode = GEMDOS_close(errorcode);
  7924.                         if (errorcode<0) { OS_error(errorcode); } # Error melden
  7925.                         if ((if_exists==3) || (if_exists==4))
  7926.                           # :RENAME oder :RENAME-AND-DELETE -> umbenennen:
  7927.                           { # Truename mit ".BAK" erweitern:
  7928.                             var reg1 object filename = STACK_0;
  7929.                             if (openp(filename)) { fehler_rename_open(filename); } # Keine offenen Dateien umbenennen!
  7930.                             pushSTACK(namestring); # namestring retten
  7931.                             # filename := (merge-pathnames ".BAK" filename) :
  7932.                             filename = copy_pathname(filename); # kopieren
  7933.                             ThePathname(filename)->pathname_type = O(backuptype_string); # mit Extension "BAK"
  7934.                             if (openp(filename)) { fehler_delete_open(filename); } # Keine offenen Dateien l÷schen!
  7935.                             pushSTACK(filename);
  7936.                            {# Directory existiert schon:
  7937.                             var reg3 object new_namestring = assume_dir_exists(); # Filename als ASCIZ-String
  7938.                             # Datei mit diesem Namen l÷schen, falls vorhanden:
  7939.                             {var reg2 sintW errorcode = # Datei zu l÷schen versuchen
  7940.                                GEMDOS_unlink(TheAsciz(new_namestring));
  7941.                              if (!(errorcode == GEMDOS_open_NotFound)) # nicht gefunden -> OK
  7942.                                if (errorcode<0) { OS_error(errorcode); } # sonstigen Error melden
  7943.                             }
  7944.                             # Datei vom alten auf diesen Namen umbenennen:
  7945.                             skipSTACK(1);
  7946.                             namestring = popSTACK(); # namestring zurⁿck
  7947.                             {var reg2 sintW errorcode = # Datei umbenennen
  7948.                                GEMDOS_rename(TheAsciz(namestring),TheAsciz(new_namestring));
  7949.                              if (errorcode<0) { OS_error(errorcode); } # Error melden
  7950.                             }
  7951.                             # :RENAME-AND-DELETE -> l÷schen:
  7952.                             if (if_exists==4)
  7953.                               {var reg2 sintW errorcode =
  7954.                                  GEMDOS_unlink(TheAsciz(new_namestring));
  7955.                                if (errorcode<0) { OS_error(errorcode); } # Error melden
  7956.                               }
  7957.                           }}
  7958.                       }
  7959.                   }
  7960.                 # Datei mit CREATE erzeugen:
  7961.                 { var reg1 sintW errorcode = # erzeugen (Attribute=0)
  7962.                     GEMDOS_create(TheAsciz(namestring),0);
  7963.                   if (errorcode<0) { OS_error(errorcode); } # Error melden
  7964.                   # Datei neu erzeugt, errorcode ist das Handle
  7965.                   handle = allocate_handle(errorcode);
  7966.                 }
  7967.                 #endif
  7968.                 #if defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM)
  7969.                 # Bei if_exists=5 und if_not_exists=3 kann man sofort
  7970.                 # CREAT ansteuern, sonst mu▀ man vorher OPEN versuchen:
  7971.                 if (!((if_exists==5) && (if_not_exists==3)))
  7972.                   { begin_system_call();
  7973.                    {var reg1 sintW ergebnis = # Datei zu ÷ffnen versuchen
  7974.                       open(TheAsciz(namestring),O_RDWR);
  7975.                     if (ergebnis<0)
  7976.                       { end_system_call();
  7977.                         if (errno == ENOENT) # nicht gefunden?
  7978.                           # Datei existiert nicht
  7979.                           { # :IF-DOES-NOT-EXIST-Argument entscheidet:
  7980.                             if (if_not_exists<2) # (Default bei :APPEND oder :OVERWRITE) oder :ERROR ?
  7981.                               goto fehler_notfound;
  7982.                             if (if_not_exists==2) # NIL -> NIL
  7983.                               goto ergebnis_NIL;
  7984.                             # :CREATE
  7985.                           }
  7986.                           else
  7987.                           { OS_error(); } # sonstigen Error melden
  7988.                       }
  7989.                       else
  7990.                       # Datei existiert, ergebnis ist das Handle
  7991.                       { # :IF-EXISTS-Argument entscheidet:
  7992.                         switch (if_exists)
  7993.                           { case 1: # :ERROR -> schlie▀en und Error
  7994.                               { if (CLOSE(ergebnis) < 0) { OS_error(); } # Error melden
  7995.                                 end_system_call();
  7996.                                 goto fehler_exists;
  7997.                               }
  7998.                             case 2: # NIL -> schlie▀en und NIL
  7999.                               { if (CLOSE(ergebnis) < 0) { OS_error(); } # Error melden
  8000.                                 end_system_call();
  8001.                                 goto ergebnis_NIL;
  8002.                               }
  8003.                             case 6: # :APPEND
  8004.                               append_flag = TRUE; # am Schlu▀ ans Ende positionieren
  8005.                             case 7: # :OVERWRITE -> bestehende Datei benutzen
  8006.                               setmode(ergebnis,O_BINARY);
  8007.                               end_system_call();
  8008.                               handle = allocate_handle(ergebnis);
  8009.                               goto handle_ok;
  8010.                             default: ;
  8011.                               # :RENAME, :RENAME-AND-DELETE -> Datei umbenennen und dann neu er÷ffnen.
  8012.                               # :NEW-VERSION, :SUPERSEDE -> Datei auf LΣnge 0 kⁿrzen.
  8013.                           }
  8014.                         # In beiden FΣllen erst die Datei schlie▀en:
  8015.                         if (CLOSE(ergebnis) < 0) { OS_error(); } # Error melden
  8016.                         end_system_call();
  8017.                         if ((if_exists==3) || (if_exists==4))
  8018.                           # :RENAME oder :RENAME-AND-DELETE -> umbenennen:
  8019.                           { # Truename mit ".BAK" erweitern:
  8020.                             var reg1 object filename = STACK_0;
  8021.                             if (openp(filename)) { fehler_rename_open(filename); } # Keine offenen Dateien umbenennen!
  8022.                             pushSTACK(namestring); # namestring retten
  8023.                             # filename := (merge-pathnames ".BAK" filename) :
  8024.                             filename = copy_pathname(filename); # kopieren
  8025.                             ThePathname(filename)->pathname_type = O(backuptype_string); # mit Extension "BAK"
  8026.                             if (openp(filename)) { fehler_delete_open(filename); } # Keine offenen Dateien l÷schen!
  8027.                             pushSTACK(filename);
  8028.                            {# Directory existiert schon:
  8029.                             var reg3 object new_namestring = assume_dir_exists(); # Filename als ASCIZ-String
  8030.                             # Datei mit diesem Namen l÷schen, falls vorhanden:
  8031.                             begin_system_call();
  8032.                             if ( unlink(TheAsciz(new_namestring)) <0) # Datei zu l÷schen versuchen
  8033.                               { if (!(errno==ENOENT)) # nicht gefunden -> OK
  8034.                                   { OS_error(); } # sonstigen Error melden
  8035.                               }
  8036.                             end_system_call();
  8037.                             # Datei vom alten auf diesen Namen umbenennen:
  8038.                             skipSTACK(1);
  8039.                             namestring = popSTACK(); # namestring zurⁿck
  8040.                             begin_system_call();
  8041.                             if ( rename(TheAsciz(namestring),TheAsciz(new_namestring)) <0) # Datei umbenennen
  8042.                               { OS_error(); } # Error melden
  8043.                             end_system_call();
  8044.                             # :RENAME-AND-DELETE -> l÷schen:
  8045.                             if (if_exists==4)
  8046.                               { begin_system_call();
  8047.                                 if ( unlink(TheAsciz(new_namestring)) <0)
  8048.                                   { OS_error(); } # Error melden
  8049.                                 end_system_call();
  8050.                               }
  8051.                           }}
  8052.                       }
  8053.                   }}
  8054.                 # Datei mit CREAT erzeugen:
  8055.                 begin_system_call();
  8056.                 { var reg1 sintW ergebnis = # erzeugen
  8057.                     creat(TheAsciz(namestring),my_open_mask);
  8058.                   if (ergebnis<0) { OS_error(); } # Error melden
  8059.                   setmode(ergebnis,O_BINARY);
  8060.                   end_system_call();
  8061.                   # Datei neu erzeugt, ergebnis ist das Handle
  8062.                   handle = allocate_handle(ergebnis);
  8063.                 }
  8064.                 #endif
  8065.                 #if defined(UNIX) || defined(AMIGAOS) || defined(RISCOS)
  8066.                 if (file_exists(namestring))
  8067.                   # Datei existiert
  8068.                   { # :IF-EXISTS-Argument entscheidet:
  8069.                     switch (if_exists)
  8070.                       { case 1: # :ERROR -> Error
  8071.                           goto fehler_exists;
  8072.                         case 2: # NIL -> NIL
  8073.                           goto ergebnis_NIL;
  8074.                         case 3: case 4: # :RENAME oder :RENAME-AND-DELETE -> umbenennen:
  8075.                           #if defined(UNIX) || defined(AMIGAOS) || defined(RISCOS)
  8076.                           { # Truename mit "%" bzw. ".bak" bzw. "~" erweitern:
  8077.                             var reg1 object filename = STACK_0;
  8078.                             var reg3 object new_namestring;
  8079.                             if (openp(filename)) { fehler_rename_open(filename); } # Keine offenen Dateien umbenennen!
  8080.                             pushSTACK(namestring); # namestring retten
  8081.                             #if defined(UNIX) || defined(AMIGAOS)
  8082.                             # filename := (parse-namestring (concatenate 'string (namestring filename) "%")) :
  8083.                             filename = whole_namestring(filename); # als String
  8084.                             pushSTACK(filename); pushSTACK(O(backupextend_string)); # "%"
  8085.                             filename = string_concat(2); # dazuhΣngen
  8086.                             pushSTACK(filename); # retten
  8087.                             filename = coerce_pathname(filename); # wieder als Filename
  8088.                             if (openp(filename)) { fehler_delete_open(filename); } # Keine offenen Dateien l÷schen!
  8089.                             # Directory existiert schon. Hier keine weiteren Links verfolgen.
  8090.                             new_namestring = string_to_asciz(popSTACK()); # Filename als ASCIZ-String
  8091.                             #endif
  8092.                             #ifdef RISCOS
  8093.                             # Dem Namen ein "~" voranstellen:
  8094.                             filename = copy_pathname(filename);
  8095.                             pushSTACK(filename);
  8096.                             pushSTACK(O(backupprepend_string)); pushSTACK(ThePathname(filename)->pathname_name);
  8097.                             { var reg1 object new_name = string_concat(2);
  8098.                               filename = STACK_0;
  8099.                               ThePathname(filename)->pathname_name = new_name;
  8100.                             }
  8101.                             if (openp(filename)) { fehler_delete_open(filename); } # Keine offenen Dateien l÷schen!
  8102.                             new_namestring = assure_dir_exists(FALSE);
  8103.                             skipSTACK(1);
  8104.                             #endif
  8105.                             # Datei (oder Link) mit diesem Namen l÷schen, falls vorhanden:
  8106.                             #if defined(AMIGAOS)
  8107.                             begin_system_call();
  8108.                             if (! DeleteFile(TheAsciz(new_namestring)) )
  8109.                               { if (!(IoErr()==ERROR_OBJECT_NOT_FOUND)) { OS_error(); } # Error melden
  8110.                                 # nicht gefunden -> OK
  8111.                               }
  8112.                             end_system_call();
  8113.                             #endif
  8114.                             #if (defined(UNIX) && 0) || defined(RISCOS) # Das tut UNIX nachher automatisch, RISCOS aber nicht
  8115.                             begin_system_call();
  8116.                             if (!( unlink(TheAsciz(new_namestring)) ==0))
  8117.                               { if (!(errno==ENOENT)) { OS_error(); } # Error melden
  8118.                                 # nicht gefunden -> OK
  8119.                               }
  8120.                             end_system_call();
  8121.                             #endif
  8122.                             # Datei vom alten auf diesen Namen umbenennen:
  8123.                             namestring = popSTACK(); # namestring zurⁿck
  8124.                             begin_system_call();
  8125.                             #ifdef AMIGAOS
  8126.                             if (! Rename(TheAsciz(namestring),TheAsciz(new_namestring)) )
  8127.                               { OS_error(); }
  8128.                             #endif
  8129.                             #if defined(UNIX) || defined(RISCOS)
  8130.                             if (!( rename(TheAsciz(namestring),TheAsciz(new_namestring)) ==0))
  8131.                               { OS_error(); }
  8132.                             #endif
  8133.                             # :RENAME-AND-DELETE -> l÷schen:
  8134.                             if (if_exists==4)
  8135.                               {
  8136.                                 #ifdef AMIGAOS
  8137.                                 if (! DeleteFile(TheAsciz(new_namestring)) )
  8138.                                   { OS_error(); }
  8139.                                 #endif
  8140.                                 #if defined(UNIX) || defined(RISCOS)
  8141.                                 if (!( unlink(TheAsciz(new_namestring)) ==0))
  8142.                                   { OS_error(); }
  8143.                                 #endif
  8144.                               }
  8145.                             end_system_call();
  8146.                           }
  8147.                           #endif
  8148.                           break;
  8149.                         case 6: # :APPEND
  8150.                           append_flag = TRUE; # am Schlu▀ ans Ende positionieren
  8151.                         default: ;
  8152.                           # :OVERWRITE -> bestehende Datei benutzen
  8153.                           # :NEW-VERSION, :SUPERSEDE -> Datei auf LΣnge 0 kⁿrzen.
  8154.                   }   }
  8155.                   else
  8156.                   # Datei existiert nicht
  8157.                   { # :IF-DOES-NOT-EXIST-Argument entscheidet:
  8158.                     if (if_not_exists<2) # (Default bei :APPEND oder :OVERWRITE) oder :ERROR ?
  8159.                       goto fehler_notfound;
  8160.                     if (if_not_exists==2) # NIL -> NIL
  8161.                       goto ergebnis_NIL;
  8162.                     # :CREATE
  8163.                   }
  8164.                 #ifdef PATHNAME_RISCOS
  8165.                 pushSTACK(namestring); prepare_create(STACK_1); namestring = popSTACK();
  8166.                 #endif
  8167.                 # Datei mit open ÷ffnen:
  8168.                 { # if-exists-Handling: bei if_exists<=5 Inhalt l÷schen,
  8169.                   # sonst (bei :APPEND, :OVERWRITE) bestehenden Inhalt lassen.
  8170.                   # if-not-exists-Handling: neue Datei erzeugen.
  8171.                   #ifdef AMIGAOS
  8172.                   var reg1 Handle handl;
  8173.                   begin_system_call();
  8174.                   handl = Open(TheAsciz(namestring),
  8175.                                (if_exists<=5 ? MODE_NEWFILE : MODE_READWRITE)
  8176.                               );
  8177.                   if (handl==Handle_NULL) { OS_error(); } # Error melden
  8178.                   end_system_call();
  8179.                   handle = allocate_handle(handl);
  8180.                   #endif
  8181.                   #if defined(UNIX) || defined(RISCOS)
  8182.                   var reg1 int ergebnis;
  8183.                   begin_system_call();
  8184.                   ergebnis = OPEN(TheAsciz(namestring),
  8185.                                   (if_exists<=5 ? O_RDWR | O_CREAT | O_TRUNC
  8186.                                                 : O_RDWR | O_CREAT
  8187.                                   ),
  8188.                                   my_open_mask
  8189.                                  );
  8190.                   if (ergebnis<0) { OS_error(); } # Error melden
  8191.                   end_system_call();
  8192.                   # Datei wurde ge÷ffnet, ergebnis ist das Handle.
  8193.                   handle = allocate_handle(ergebnis);
  8194.                   #endif
  8195.                 }
  8196.                 #endif
  8197.                 break;
  8198.               }
  8199.             ergebnis_NIL: # Ergebnis NIL
  8200.               skipSTACK(2); # beide Pathnames vergessen
  8201.               return NIL;
  8202.             fehler_notfound: # Fehler, da Datei nicht gefunden
  8203.               # STACK_0 = Truename, Wert fⁿr Slot PATHNAME von FILE-ERROR
  8204.               pushSTACK(STACK_0);
  8205.               fehler(file_error,
  8206.                      DEUTSCH ? "Eine Datei mit Namen ~ existiert nicht." :
  8207.                      ENGLISH ? "file ~ does not exist" :
  8208.                      FRANCAIS ? "Un fichier de nom ~ n'existe pas." :
  8209.                      ""
  8210.                     );
  8211.             fehler_exists: # Fehler, da Datei bereits existiert
  8212.               # STACK_0 = Truename, Wert fⁿr Slot PATHNAME von FILE-ERROR
  8213.               pushSTACK(STACK_0);
  8214.               fehler(file_error,
  8215.                      DEUTSCH ? "Eine Datei mit Namen ~ existiert bereits." :
  8216.                      ENGLISH ? "a file named ~ already exists" :
  8217.                      FRANCAIS ? "Un fichier de nom ~ existe dΘjα." :
  8218.                      ""
  8219.                     );
  8220.           }
  8221.         handle_ok:
  8222.         # handle und append_flag sind jetzt fertig.
  8223.         # Stream erzeugen:
  8224.         return make_file_stream(handle,direction,type,eltype_size,append_flag);
  8225.     } }
  8226.  
  8227. LISPFUN(open,1,0,norest,key,4,\
  8228.         (kw(direction),kw(element_type),kw(if_exists),kw(if_does_not_exist)) )
  8229. # (OPEN filename :direction :element-type :if-exists :if-does-not-exist),
  8230. # CLTL S. 418
  8231.   { var reg2 object filename = STACK_4; # filename
  8232.     if (streamp(filename))
  8233.       { # mu▀ File-Stream sein:
  8234.         filename = as_file_stream(filename);
  8235.         # Streamtyp File-Stream -> Truename verwenden:
  8236.         filename = TheStream(filename)->strm_file_truename;
  8237.       }
  8238.       else
  8239.       { filename = coerce_pathname(filename); } # zu einem Pathname machen
  8240.     # filename ist jetzt ein Pathname.
  8241.    {var reg3 uintB direction;
  8242.     var reg4 uintB if_exists;
  8243.     var reg5 uintB if_not_exists;
  8244.     var reg6 uintB type;
  8245.     var reg7 object eltype_size = NIL;
  8246.     # :direction ⁿberprⁿfen und in direction ⁿbersetzen:
  8247.     { var reg1 object arg = STACK_3;
  8248.       if (eq(arg,unbound) || eq(arg,S(Kinput))) { direction = 1; }
  8249.       elif (eq(arg,S(Kinput_immutable))) { direction = 3; }
  8250.       elif (eq(arg,S(Koutput))) { direction = 4; }
  8251.       elif (eq(arg,S(Kio))) { direction = 5; }
  8252.       elif (eq(arg,S(Kprobe))) { direction = 0; }
  8253.       else
  8254.       { pushSTACK(arg); # Wert fⁿr Slot DATUM von TYPE-ERROR
  8255.         pushSTACK(O(type_direction)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  8256.         pushSTACK(arg); pushSTACK(S(open));
  8257.         fehler(type_error,
  8258.                DEUTSCH ? "~: Als :DIRECTION-Argument ist ~ unzulΣssig." :
  8259.                ENGLISH ? "~: illegal :DIRECTION argument ~" :
  8260.                FRANCAIS ? "~ : ~ n'est pas permis comme argument pour :DIRECTION." :
  8261.                ""
  8262.               );
  8263.     } }
  8264.     # :element-type ⁿberprⁿfen und in type und eltype_size ⁿbersetzen:
  8265.     { var reg1 object arg = STACK_2;
  8266.       if (eq(arg,unbound) || eq(arg,S(string_char)) || eq(arg,S(Kdefault))) # STRING-CHAR, :DEFAULT
  8267.         { type = strmtype_sch_file; }
  8268.       elif (eq(arg,S(character))) # CHARACTER
  8269.         { type = strmtype_ch_file; }
  8270.       elif (eq(arg,S(bit))) # BIT
  8271.         { type = strmtype_iu_file; eltype_size = Fixnum_1; }
  8272.       elif (eq(arg,S(unsigned_byte))) # UNSIGNED-BYTE
  8273.         { type = strmtype_iu_file; eltype_size = fixnum(8); }
  8274.       elif (eq(arg,S(signed_byte))) # SIGNED-BYTE
  8275.         { type = strmtype_is_file; eltype_size = fixnum(8); }
  8276.       elif (consp(arg) && mconsp(Cdr(arg)) && nullp(Cdr(Cdr(arg)))) # zweielementige Liste
  8277.         { var reg2 object h = Car(arg);
  8278.           if (eq(h,S(mod))) # (MOD n)
  8279.             { type = strmtype_iu_file;
  8280.               h = Car(Cdr(arg)); # n
  8281.               # mu▀ ein Integer >0 sein:
  8282.               if (!(integerp(h) && positivep(h) && !eq(h,Fixnum_0)))
  8283.                 goto bad_eltype;
  8284.               # eltype_size := (integer-length (1- n)) bilden:
  8285.               pushSTACK(filename); # filename retten
  8286.               pushSTACK(h); funcall(L(einsminus),1); # (1- n)
  8287.               pushSTACK(value1); funcall(L(integer_length),1); # (integer-length (1- n))
  8288.               eltype_size = value1;
  8289.               filename = popSTACK(); # filename zurⁿck
  8290.             }
  8291.           elif (eq(h,S(unsigned_byte))) # (UNSIGNED-BYTE n)
  8292.             { type = strmtype_iu_file;
  8293.               eltype_size = Car(Cdr(arg));
  8294.             }
  8295.           elif (eq(h,S(signed_byte))) # (SIGNED-BYTE n)
  8296.             { type = strmtype_is_file;
  8297.               eltype_size = Car(Cdr(arg));
  8298.             }
  8299.           else goto bad_eltype;
  8300.           # eltype_size ⁿberprⁿfen:
  8301.           if (!(posfixnump(eltype_size) && !eq(eltype_size,Fixnum_0)
  8302.                 && ((oint_data_len < log2_intDsize+intCsize) # (Bei oint_data_len <= log2(intDsize)+intCsize-1
  8303.                     # ist stets eltype_size < 2^oint_data_len < intDsize*(2^intCsize-1).)
  8304.                     || (as_oint(eltype_size) < as_oint(fixnum(intDsize*(uintL)(bitm(intCsize)-1))))
  8305.              ) )   )
  8306.             goto bad_eltype;
  8307.         }
  8308.       else
  8309.         { bad_eltype:
  8310.           pushSTACK(STACK_2); pushSTACK(S(open));
  8311.           fehler(error, # type_error ??
  8312.                  DEUTSCH ? "~: Als :ELEMENT-TYPE-Argument ist ~ unzulΣssig." :
  8313.                  ENGLISH ? "~: illegal :ELEMENT-TYPE argument ~" :
  8314.                  FRANCAIS ? "~ : ~ n'est pas permis comme argument pour :ELEMENT-TYPE." :
  8315.                  ""
  8316.                 );
  8317.     }   }
  8318.     # :if-exists ⁿberprⁿfen und in if_exists ⁿbersetzen:
  8319.     { var reg1 object arg = STACK_1;
  8320.       if (eq(arg,unbound)) { if_exists = 0; }
  8321.       elif (eq(arg,S(Kerror))) { if_exists = 1; }
  8322.       elif (eq(arg,NIL)) { if_exists = 2; }
  8323.       elif (eq(arg,S(Krename))) { if_exists = 3; }
  8324.       elif (eq(arg,S(Krename_and_delete))) { if_exists = 4; }
  8325.       elif (eq(arg,S(Knew_version)) || eq(arg,S(Ksupersede))) { if_exists = 5; }
  8326.       elif (eq(arg,S(Kappend))) { if_exists = 6; }
  8327.       elif (eq(arg,S(Koverwrite))) { if_exists = 7; }
  8328.       else
  8329.       { pushSTACK(arg); # Wert fⁿr Slot DATUM von TYPE-ERROR
  8330.         pushSTACK(O(type_if_exists)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  8331.         pushSTACK(arg); pushSTACK(S(open));
  8332.         fehler(type_error,
  8333.                DEUTSCH ? "~: Als :IF-EXISTS-Argument ist ~ unzulΣssig." :
  8334.                ENGLISH ? "~: illegal :IF-EXISTS argument ~" :
  8335.                FRANCAIS ? "~ : ~ n'est pas permis comme argument pour :IF-EXISTS." :
  8336.                ""
  8337.               );
  8338.     } }
  8339.     # :if-does-not-exist ⁿberprⁿfen und in if_not_exists ⁿbersetzen:
  8340.     { var reg1 object arg = STACK_0;
  8341.       if (eq(arg,unbound)) { if_not_exists = 0; }
  8342.       elif (eq(arg,S(Kerror))) { if_not_exists = 1; }
  8343.       elif (eq(arg,NIL)) { if_not_exists = 2; }
  8344.       elif (eq(arg,S(Kcreate))) { if_not_exists = 3; }
  8345.       else
  8346.       { pushSTACK(arg); # Wert fⁿr Slot DATUM von TYPE-ERROR
  8347.         pushSTACK(O(type_if_does_not_exist)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  8348.         pushSTACK(arg); pushSTACK(S(open));
  8349.         fehler(type_error,
  8350.                DEUTSCH ? "~: Als :IF-DOES-NOT-EXIST-Argument ist ~ unzulΣssig." :
  8351.                ENGLISH ? "~: illegal :IF-DOES-NOT-EXIST argument ~" :
  8352.                FRANCAIS ? "~ : ~ n'est pas permis comme argument pour :IF-DOES-NOT-EXIST." :
  8353.                ""
  8354.               );
  8355.     } }
  8356.     # File ÷ffnen:
  8357.     skipSTACK(5);
  8358.     value1 = open_file(filename,direction,if_exists,if_not_exists,type,eltype_size);
  8359.     mv_count=1;
  8360.   }}
  8361.  
  8362. # UP: Liefert eine Liste aller matchenden Pathnames.
  8363. # directory_search(pathname)
  8364. # > pathname: Pathname mit Device /= :WILD
  8365. #ifdef UNIX
  8366. # > STACK_1: Circle-Flag
  8367. #endif
  8368. # > STACK_0: Full-Flag
  8369. # < ergebnis:
  8370. #     Falls name=NIL und type=NIL:     Liste aller matchenden Directories,
  8371. #     sonst (name=NIL -> name=:WILD):  Liste aller matchenden Dateien.
  8372. #     Jeweils als absoluter Pathname ohne Wildcards,
  8373. #     bzw. bei Dateien und Full-Flag /=NIL als Liste
  8374. #          (Pathname Write-Date Length)
  8375. #          mit  Pathname ohne :WILD/:WILD-INFERIORS-Komponenten,
  8376. #               Write-Date = Datum der Dateierstellung (ss mm hh dd mm yy),
  8377. #                 als Decoded-Time passend fⁿr ENCODE-UNIVERSAL-TIME,
  8378. #               Length = LΣnge der Datei (in Bytes).
  8379. # kann GC ausl÷sen
  8380.   local object directory_search (object pathname);
  8381.   # Methode: Breadth-first-search, damit nur eine Suchoperation gleichzeitig
  8382.   # lΣuft (und auf dem ATARI nur 1 DTA-Buffer gebraucht wird).
  8383.   #
  8384.   #ifdef PATHNAME_EXT83
  8385.   #
  8386.   #ifdef WATCOM
  8387.     # Die findfirst/findnext-Routinen sollen gefΣlligst errno setzen:
  8388.     local int findfirst (const char * path, struct ffblk * buf, unsigned int attr);
  8389.     local int findnext (struct ffblk * buf);
  8390.     local int findfirst(path,buf,attr)
  8391.       var reg2 const char * path;
  8392.       var reg3 struct ffblk * buf;
  8393.       var reg4 unsigned int attr;
  8394.       { var reg1 unsigned int result = _dos_findfirst(path,attr,buf);
  8395.         if (result==0)
  8396.           { return 0; } # kein Error
  8397.           else
  8398.           { errno = result; # = _doserrno;
  8399.             return -1; # Error
  8400.       }   }
  8401.     local int findnext(buf)
  8402.       var reg2 struct ffblk * buf;
  8403.       { var reg1 unsigned int result = _dos_findnext(buf);
  8404.         if (result==0)
  8405.           { return 0; } # kein Error
  8406.           else
  8407.           { errno = result; # = _doserrno;
  8408.             return -1; # Error
  8409.       }   }
  8410.   #endif
  8411.   #
  8412.   # UP: Extrahiert Name und Typ aus dem DTA-Buffer.
  8413.   # Es wird angenommen, da▀ Name und Typ aus zulΣssigen Gro▀buchstaben
  8414.   # bestehen und eine LΣnge <= 8 bzw. 3 haben.
  8415.   # > asciz: Adresse des ASCIZ-Strings im DTA-Buffer
  8416.   # > def: Default-Typ
  8417.   # < -(STACK): Typ
  8418.   # < -(STACK): Name
  8419.   # Erniedrigt STACK um 2.
  8420.   # kann GC ausl÷sen
  8421.     local void extract (const uintB* asciz, object def);
  8422.     local void extract(asciz,def)
  8423.       var reg3 const uintB* asciz;
  8424.       var reg4 object def;
  8425.       { pushSTACK(def); # Default-Typ in den Stack
  8426.        {# in Name.Typ aufspalten:
  8427.         var reg1 const uintB* ptr = asciz;
  8428.         var reg2 uintL count = 0;
  8429.         loop
  8430.           { var reg3 uintB ch = *ptr; # nΣchstes Zeichen
  8431.             if ((ch == 0) || (ch == '.')) # bei Nullbyte oder '.'
  8432.               break; # ist der Name zu Ende
  8433.             ptr++; count++; # weiterrⁿcken
  8434.           }
  8435.         pushSTACK(make_string(asciz,count)); # String fⁿr Name erzeugen
  8436.         if (*ptr++ == 0) # mit Nullbyte beendet ?
  8437.           ; # ja -> Typ bleibt Default
  8438.           else
  8439.           { asciz = ptr; count = 0;
  8440.             until (*ptr++ == 0) { count++; } # bei Nullbyte ist der Typ zu Ende
  8441.             STACK_1 = make_string(asciz,count); # String fⁿr Typ erzeugen
  8442.           }
  8443.       }}
  8444.   #
  8445.   # UP: Sucht Subdirectories eines gegebenen Pathname.
  8446.   # subdirs(pathstring)
  8447.   # STACK_0 = Pathname, dessen Subdirectories zu suchen sind
  8448.   # STACK_1 = Liste, auf die die Pathnames der matchenden Subdirectories
  8449.   #           gepusht werden
  8450.   # > pathstring: Suchpfad als fertiger ASCIZ-String
  8451.   # verΣndert STACK_1, kann GC ausl÷sen
  8452.     local void subdirs (object pathstring);
  8453.     local void subdirs(pathstring)
  8454.       var reg3 object pathstring;
  8455.       {
  8456.        #ifdef ATARI
  8457.         # Dateisuche gemΣ▀ GEMDOS-Konvention:
  8458.         var reg2 sintW errorcode;
  8459.         set_break_sem_4(); # wegen DTA-Buffer gegen Unterbrechungen sperren
  8460.         GEMDOS_SetDTA(&DTA_buffer); # DTA-Buffer setzen
  8461.         # Suchanfang, die Maske 0x10 sucht nach Ordnern und normalen Dateien:
  8462.         errorcode =
  8463.           GEMDOS_Sfirst(TheAsciz(pathstring),0x10);
  8464.         if (!(errorcode == GEMDOS_Sfirst_notfound)) # 'Keine Datei gefunden' ?
  8465.           # ja -> Schleife nicht durchlaufen
  8466.           loop
  8467.             { if (errorcode < 0) { OS_error(errorcode); } # sonstigen Error melden
  8468.               # Stackaufbau: new-pathname-list, pathname.
  8469.               # gefundene Datei untersuchen:
  8470.               if (DTA_buffer.d_attrib & 0x10) # sollte ein Unterdirectory sein
  8471.                 if (!(DTA_buffer.d_fname[0] == '.')) # sollte nicht mit '.' anfangen
  8472.                   # (sonst ist es wohl '.' oder '..', wird ⁿbergangen)
  8473.                   { # in Name.Typ aufspalten, Default-Typ "" :
  8474.                     extract(&DTA_buffer.d_fname[0],O(leer_string));
  8475.                    {var reg1 object new_cons = allocate_cons();
  8476.                     Car(new_cons) = popSTACK(); Cdr(new_cons) = popSTACK();
  8477.                     # new_cons = (name . type)
  8478.                     pushSTACK(new_cons);
  8479.                     new_cons = allocate_cons();
  8480.                     Car(new_cons) = popSTACK();
  8481.                     # in ein-elementiger Liste new_cons = list1 = ((name . type))
  8482.                     pushSTACK(new_cons);
  8483.                    }# Stackaufbau: new-pathname-list, pathname, list1.
  8484.                     # letzten Pathname kopieren:
  8485.                    {var reg1 object temp = copy_pathname(STACK_1);
  8486.                     pushSTACK(temp);
  8487.                     # und darin Directory um list1 = ((name . type)) verlΣngern:
  8488.                     # (append pathname-dir list1) = (nreconc (reverse pathname-dir) list1)
  8489.                     temp = reverse(ThePathname(temp)->pathname_directory);
  8490.                     temp = nreconc(temp,STACK_1);
  8491.                     ThePathname(STACK_0)->pathname_directory = temp;
  8492.                    }# Stackaufbau: new-pathname-list, pathname, list1, newpathname.
  8493.                     # newpathname auf die Liste new-pathname-list pushen:
  8494.                    {var reg1 object new_cons = allocate_cons();
  8495.                     Car(new_cons) = popSTACK(); skipSTACK(1);
  8496.                     Cdr(new_cons) = STACK_1; STACK_1 = new_cons;
  8497.                   }}
  8498.               # nΣchstes File:
  8499.               errorcode = GEMDOS_Snext();
  8500.               if (errorcode == GEMDOS_Snext_notfound) # 'Keine weitere Datei gefunden' ?
  8501.                 break; # ja -> Schleifenende
  8502.             }
  8503.         clr_break_sem_4();
  8504.        #endif
  8505.        #ifdef MSDOS
  8506.         # Dateisuche gemΣ▀ DOS-Konvention:
  8507.         var struct ffblk DTA_buffer;
  8508.         set_break_sem_4(); # wegen DTA-Buffer gegen Unterbrechungen sperren
  8509.         # Suchanfang, suche nach Ordnern und normalen Dateien:
  8510.         begin_system_call();
  8511.         if (findfirst(TheAsciz(pathstring),&DTA_buffer,FA_DIREC|FA_ARCH|FA_RDONLY) <0)
  8512.           { if (!((errno==ENOENT) || (errno==ENOMORE))) { OS_error(); } }
  8513.           else # Keine Datei gefunden -> Schleife nicht durchlaufen
  8514.           loop
  8515.             { # Stackaufbau: new-pathname-list, pathname.
  8516.               end_system_call();
  8517.               # gefundene Datei untersuchen:
  8518.               if (DTA_buffer.ff_attrib & FA_DIREC) # sollte ein Unterdirectory sein
  8519.                 if (!(DTA_buffer.ff_name[0] == '.')) # sollte nicht mit '.' anfangen
  8520.                   # (sonst ist es wohl '.' oder '..', wird ⁿbergangen)
  8521.                   { # in Name.Typ aufspalten, Default-Typ "" :
  8522.                     extract(&DTA_buffer.ff_name[0],O(leer_string));
  8523.                    {var reg1 object new_cons = allocate_cons();
  8524.                     Car(new_cons) = popSTACK(); Cdr(new_cons) = popSTACK();
  8525.                     # new_cons = (name . type)
  8526.                     pushSTACK(new_cons);
  8527.                     new_cons = allocate_cons();
  8528.                     Car(new_cons) = popSTACK();
  8529.                     # in ein-elementiger Liste new_cons = list1 = ((name . type))
  8530.                     pushSTACK(new_cons);
  8531.                    }# Stackaufbau: new-pathname-list, pathname, list1.
  8532.                     # letzten Pathname kopieren:
  8533.                    {var reg1 object temp = copy_pathname(STACK_1);
  8534.                     pushSTACK(temp);
  8535.                     # und darin Directory um list1 = ((name . type)) verlΣngern:
  8536.                     # (append pathname-dir list1) = (nreconc (reverse pathname-dir) list1)
  8537.                     temp = reverse(ThePathname(temp)->pathname_directory);
  8538.                     temp = nreconc(temp,STACK_1);
  8539.                     ThePathname(STACK_0)->pathname_directory = temp;
  8540.                    }# Stackaufbau: new-pathname-list, pathname, list1, newpathname.
  8541.                     # newpathname auf die Liste new-pathname-list pushen:
  8542.                    {var reg1 object new_cons = allocate_cons();
  8543.                     Car(new_cons) = popSTACK(); skipSTACK(1);
  8544.                     Cdr(new_cons) = STACK_1; STACK_1 = new_cons;
  8545.                   }}
  8546.               # nΣchstes File:
  8547.               begin_system_call();
  8548.               if (findnext(&DTA_buffer) <0)
  8549.                 { if (!((errno==ENOENT) || (errno==ENOMORE))) { OS_error(); }
  8550.                   break; # Keine weitere Datei -> Schleifenende
  8551.                 }
  8552.             }
  8553.         end_system_call();
  8554.         clr_break_sem_4();
  8555.        #endif
  8556.       }
  8557.   #
  8558.   # UP: Sucht alle Subdirectories (beliebiger Tiefe) eines gegebenen Pathname.
  8559.   # allsubdirs(pathnamelist)
  8560.   # > pathnamelist: Liste, dessen CAR der gegebene Pathname ist.
  8561.   # Die Pathnames aller echten Subdirectories (beliebiger Tiefe) werden als
  8562.   # Liste destruktiv zwischen pathnamelist und (cdr pathnamelist) gehΣngt.
  8563.   # < ergebnis: das ursprⁿngliche (cdr pathnamelist)
  8564.   # kann GC ausl÷sen
  8565.     local object allsubdirs (object pathnamelist);
  8566.     local object allsubdirs(pathnamelist)
  8567.       var reg1 object pathnamelist;
  8568.       { pushSTACK(pathnamelist);
  8569.         pushSTACK(NIL); # new-pathname-list := NIL
  8570.         {var reg2 object pathname = Car(pathnamelist);
  8571.          pushSTACK(pathname);
  8572.          # Stackaufbau: pathnamelist, new-pathname-list, pathname.
  8573.          {var reg3 uintC stringcount =
  8574.             directory_namestring_parts_(pathname); # Directory-Namestring-Teile,
  8575.           pushSTACK(O(wild_wild_string)); # "*.*"
  8576.           pushSTACK(O(null_string)); # und Nullbyte
  8577.           {var reg4 object pathstring = string_concat(stringcount+1+1); # zusammenhΣngen
  8578.            subdirs(pathstring); # alle subdirs auf new-pathname-list pushen
  8579.         }}}
  8580.         skipSTACK(1); # pathname vergessen
  8581.         { var reg2 object new_pathname_list = popSTACK();
  8582.           pathnamelist = popSTACK();
  8583.           # Stackaufbau: (leer).
  8584.           # Mit  (setf (cdr pathnamelist)
  8585.           #            (nreconc new-pathname-list (cdr pathnamelist))
  8586.           #      )
  8587.           # die new-pathname-list umdrehen und gleichzeitig einhΣngen:
  8588.           new_pathname_list = nreconc(new_pathname_list,Cdr(pathnamelist));
  8589.           pushSTACK(Cdr(pathnamelist)); Cdr(pathnamelist) = new_pathname_list;
  8590.           pathnamelist = new_pathname_list;
  8591.         }
  8592.         # Stackaufbau: ursprⁿngliches (cdr pathnamelist).
  8593.         # Liste pathnamelist durchlaufen, bis bei STACK_0 angelangt,
  8594.         # und rekursiv alle Subdirectories bestimmen und einhΣngen:
  8595.         until (eq(pathnamelist,STACK_0))
  8596.           { pathnamelist = allsubdirs(pathnamelist); }
  8597.         skipSTACK(1);
  8598.         return pathnamelist;
  8599.       }
  8600.   #
  8601.   local object directory_search(pathname)
  8602.     var reg4 object pathname;
  8603.     { pathname = use_default_dir(pathname); # Default-Directory einfⁿgen
  8604.       # pathname ist jetzt ein Pathname, bei dem Device ein ⁿberprⁿfter
  8605.       # String ist und Directory [die Seriennummer, aber] kein
  8606.       # :RELATIVE, :CURRENT, :PARENT enthΣlt.
  8607.       pushSTACK(pathname);
  8608.       #if HAS_SERNR
  8609.       pushSTACK(Cdr(ThePathname(pathname)->pathname_directory)); # subdir-list
  8610.       #else
  8611.       pushSTACK(ThePathname(pathname)->pathname_directory); # subdir-list
  8612.       #endif
  8613.       # pathname kopieren:
  8614.       pushSTACK(copy_pathname(pathname));
  8615.       # und dessen Directory auf ([Seriennummer] :ABSOLUTE) verkⁿrzen:
  8616.       {var reg1 object new_cons = allocate_cons(); # neues Cons mit CDR=NIL
  8617.        Car(new_cons) = S(Kabsolute); # :ABSOLUTE als CAR
  8618.        #if HAS_SERNR
  8619.        pushSTACK(new_cons);
  8620.        new_cons = allocate_cons(); # neues Cons
  8621.        Cdr(new_cons) = popSTACK(); # mit anderem Cons als CDR
  8622.        Car(new_cons) = Car(ThePathname(STACK_0)->pathname_directory); # und Seriennummer als CAR
  8623.        #endif
  8624.        ThePathname(STACK_0)->pathname_directory = new_cons;
  8625.       }
  8626.       # und in einelementige Liste packen:
  8627.       {var reg1 object new_cons = allocate_cons();
  8628.        Car(new_cons) = STACK_0;
  8629.        STACK_0 = new_cons;
  8630.       }
  8631.       while
  8632.         # Stackaufbau: pathname, subdir-list, pathname-list.
  8633.         # Dabei enthalten die Pathnames aus pathname-list das Directory
  8634.         # nur so tief, da▀ es danach mit (cdr subdir-list) weitergeht.
  8635.         # NΣchste subdir-Ebene abarbeiten:
  8636.         (consp (STACK_1 = Cdr(STACK_1))) # subdir-list verkⁿrzen
  8637.         { # pathname-list durchgehen und dabei neue Liste aufbauen:
  8638.           pushSTACK(STACK_0); pushSTACK(NIL);
  8639.           loop
  8640.             { # Stackaufbau: ..., pathname-list-rest, new-pathname-list.
  8641.               var reg2 object pathname_list_rest = STACK_1;
  8642.               if (atomp(pathname_list_rest)) break;
  8643.               STACK_1 = Cdr(pathname_list_rest);
  8644.              {var reg5 object next_pathname = Car(pathname_list_rest); # nΣchster Pathname
  8645.               var reg3 object subdir_list = STACK_(1+2);
  8646.               pushSTACK(next_pathname); # in den Stack
  8647.               if (!eq(Car(subdir_list),S(Kwild_inferiors))) # nΣchstes subdir = :WILD-INFERIORS ?
  8648.                 { # normales subdir:
  8649.                   var reg1 uintC stringcount =
  8650.                     directory_namestring_parts_(next_pathname); # Directory-Namestring-Teile (keine GC!)
  8651.                   stringcount +=
  8652.                     subdir_namestring_parts(subdir_list); # und Strings zum nΣchsten subdir
  8653.                   pushSTACK(O(null_string)); stringcount += 1; # und Nullbyte
  8654.                  {var reg6 object pathstring = string_concat(stringcount); # zusammenhΣngen
  8655.                   subdirs(pathstring); # alle subdirs auf new-pathname-list pushen
  8656.                   skipSTACK(1); # next-pathname vergessen
  8657.                 }}
  8658.                 else
  8659.                 { # subdir = :WILD-INFERIORS -> alle Subdirs bestimmen:
  8660.                   {var reg1 object list1 = allocate_cons();
  8661.                    Car(list1) = STACK_0;
  8662.                    STACK_0 = list1; # einelementige Liste (next-pathname)
  8663.                    allsubdirs(list1); # alle Subdirectories bestimmen
  8664.                   }
  8665.                   # Liste aller Subdirectories vor new-pathname-list
  8666.                   # in umgekehrter Reihenfolge davorhΣngen:
  8667.                   # (nreconc subdirlist new-pathname-list)
  8668.                   {var reg1 object newsubdirlist = popSTACK();
  8669.                    STACK_0 = nreconc(newsubdirlist,STACK_0);
  8670.                 } }
  8671.               # nΣchsten Pathname aus pathname-list-rest nehmen
  8672.             }}
  8673.          {var reg1 object new_pathname_list = popSTACK(); skipSTACK(1);
  8674.           # umdrehen und als nΣchste pathname-list verwenden:
  8675.           STACK_0 = nreverse(new_pathname_list);
  8676.         }}
  8677.       # Stackaufbau: pathname, nix, pathname-list.
  8678.       pathname = STACK_2;
  8679.       {var reg2 object name = ThePathname(pathname)->pathname_name;
  8680.        var reg3 object type = ThePathname(pathname)->pathname_type;
  8681.        if (nullp(name)) # Name=NIL ?
  8682.          { if (nullp(type)) # auch Typ=NIL ?
  8683.              { var reg1 object new_pathname_list = popSTACK(); # ja ->
  8684.                skipSTACK(2); return new_pathname_list; # schon fertig
  8685.              }
  8686.              else
  8687.              # nein -> verwende :WILD (statt NIL) als Name
  8688.              { name = S(Kwild); }
  8689.          }
  8690.        # Alle Files name.type in den gegebenen Subdirectories suchen:
  8691.        { var reg1 uintC stringcount =
  8692.            nametype_namestring_parts(name,type,ThePathname(pathname)->pathname_version); # Teilstrings zu Name und Typ
  8693.          pushSTACK(O(null_string)); stringcount++; # und Nullbyte
  8694.         {var reg2 object name_type_asciz = string_concat(stringcount);
  8695.          STACK_2 = name_type_asciz;
  8696.       }}}
  8697.       STACK_1 = STACK_0; # pathname-list
  8698.       STACK_0 = NIL; # new-pathname-list := NIL
  8699.       # Stackaufbau: name-type-asciz, pathname-list, new-pathname-list.
  8700.       loop
  8701.         { var reg5 object pathname_list_rest = STACK_1;
  8702.           if (atomp(pathname_list_rest)) break;
  8703.           STACK_1 = Cdr(pathname_list_rest);
  8704.          {var reg8 object next_pathname = Car(pathname_list_rest); # nΣchster Pathname
  8705.           var reg7 object name_type_asciz = STACK_2;
  8706.           pushSTACK(next_pathname); # in den Stack
  8707.           {var reg3 uintC stringcount =
  8708.              directory_namestring_parts_(next_pathname); # Directory-Namestring-Teile (keine GC!)
  8709.            pushSTACK(name_type_asciz); stringcount += 1; # und name-type-asciz
  8710.            {var reg6 object pathstring = string_concat(stringcount); # zusammenhΣngen
  8711.             #ifdef ATARI
  8712.              # Dateisuche gemΣ▀ GEMDOS-Konvention:
  8713.              var reg2 sintW errorcode;
  8714.              set_break_sem_4(); # wegen DTA-Buffer gegen Unterbrechungen sperren
  8715.              GEMDOS_SetDTA(&DTA_buffer); # DTA-Buffer setzen
  8716.              # Suchanfang, die Maske 0x00 sucht nur nach normalen Dateien:
  8717.              errorcode =
  8718.                GEMDOS_Sfirst(TheAsciz(pathstring),0x00);
  8719.              if (!(errorcode == GEMDOS_Sfirst_notfound)) # 'Keine Datei gefunden' ?
  8720.                # ja -> Schleife nicht durchlaufen
  8721.                loop
  8722.                  { if (errorcode < 0) { OS_error(errorcode); } # sonstigen Error melden
  8723.                    # Stackaufbau: ..., next-pathname.
  8724.                    # gefundene Datei untersuchen:
  8725.                    { # in Name.Typ aufspalten, Default-Typ NIL :
  8726.                      extract(&DTA_buffer.d_fname[0],NIL);
  8727.                     {# letzten Pathname kopieren und Name und Typ eintragen:
  8728.                      var reg1 object new = copy_pathname(STACK_2);
  8729.                      ThePathname(new)->pathname_name = popSTACK();
  8730.                      ThePathname(new)->pathname_type = popSTACK();
  8731.                      # Full-Flag abtesten und evtl. mehr Information besorgen:
  8732.                      if (!nullp(STACK_(0+3+1)))
  8733.                        { pushSTACK(new); # newpathname als 1. Listenelement
  8734.                          pushSTACK(new); # newpathname als 2. Listenelement
  8735.                          { # Uhrzeit und Datum von Atari-Format in Decoded-Time umwandeln:
  8736.                            var decoded_time timepoint;
  8737.                            convert_timedate(DTA_buffer.d_time,DTA_buffer.d_date,
  8738.                                         &timepoint);
  8739.                            pushSTACK(timepoint.Sekunden);
  8740.                            pushSTACK(timepoint.Minuten);
  8741.                            pushSTACK(timepoint.Stunden);
  8742.                            pushSTACK(timepoint.Tag);
  8743.                            pushSTACK(timepoint.Monat);
  8744.                            pushSTACK(timepoint.Jahr);
  8745.                            new = listof(6); # 6-elementige Liste bauen
  8746.                          }
  8747.                          pushSTACK(new); # als 3. Listenelement
  8748.                          pushSTACK(UL_to_I(DTA_buffer.d_length)); # LΣnge als 4. Listenelement
  8749.                          new = listof(4); # 4-elementige Liste bauen
  8750.                        }
  8751.                      # new auf die Liste new-pathname-list pushen:
  8752.                       pushSTACK(new);
  8753.                      {var reg1 object new_cons = allocate_cons();
  8754.                       Car(new_cons) = popSTACK();
  8755.                       Cdr(new_cons) = STACK_(0+1);
  8756.                       STACK_(0+1) = new_cons;
  8757.                    }}}
  8758.                    # nΣchstes File:
  8759.                    errorcode = GEMDOS_Snext();
  8760.                    if (errorcode == GEMDOS_Snext_notfound) # 'Keine weitere Datei gefunden' ?
  8761.                      break; # ja -> Schleifenende
  8762.                  }
  8763.              clr_break_sem_4();
  8764.             #endif
  8765.             #ifdef MSDOS
  8766.              # Dateisuche gemΣ▀ DOS-Konvention:
  8767.              var struct ffblk DTA_buffer;
  8768.              set_break_sem_4(); # wegen DTA-Buffer gegen Unterbrechungen sperren
  8769.              # Suchanfang, suche nur nach normalen Dateien:
  8770.              begin_system_call();
  8771.              if (findfirst(TheAsciz(pathstring),&DTA_buffer,FA_ARCH|FA_RDONLY) <0)
  8772.                { if (!((errno==ENOENT) || (errno==ENOMORE))) { OS_error(); } }
  8773.                else # Keine Datei gefunden -> Schleife nicht durchlaufen
  8774.                loop
  8775.                  { # Stackaufbau: ..., next-pathname.
  8776.                    end_system_call();
  8777.                    # gefundene Datei untersuchen:
  8778.                    { # in Name.Typ aufspalten, Default-Typ NIL :
  8779.                      extract(&DTA_buffer.ff_name[0],NIL);
  8780.                     {# letzten Pathname kopieren und Name und Typ eintragen:
  8781.                      var reg1 object new = copy_pathname(STACK_2);
  8782.                      ThePathname(new)->pathname_name = popSTACK();
  8783.                      ThePathname(new)->pathname_type = popSTACK();
  8784.                      # Full-Flag abtesten und evtl. mehr Information besorgen:
  8785.                      if (!nullp(STACK_(0+3+1)))
  8786.                        { pushSTACK(new); # newpathname als 1. Listenelement
  8787.                          pushSTACK(new); # newpathname als 2. Listenelement
  8788.                          { # Uhrzeit und Datum von DOS-Format in Decoded-Time umwandeln:
  8789.                            var decoded_time timepoint;
  8790.                            convert_timedate((uintW)DTA_buffer.ff_ftime,(uintW)DTA_buffer.ff_fdate,
  8791.                                         &timepoint);
  8792.                            pushSTACK(timepoint.Sekunden);
  8793.                            pushSTACK(timepoint.Minuten);
  8794.                            pushSTACK(timepoint.Stunden);
  8795.                            pushSTACK(timepoint.Tag);
  8796.                            pushSTACK(timepoint.Monat);
  8797.                            pushSTACK(timepoint.Jahr);
  8798.                            new = listof(6); # 6-elementige Liste bauen
  8799.                          }
  8800.                          pushSTACK(new); # als 3. Listenelement
  8801.                          pushSTACK(UL_to_I(*(uintL*)(&DTA_buffer.ff_fsize))); # LΣnge als 4. Listenelement
  8802.                          new = listof(4); # 4-elementige Liste bauen
  8803.                        }
  8804.                      # new auf die Liste new-pathname-list pushen:
  8805.                       pushSTACK(new);
  8806.                      {var reg1 object new_cons = allocate_cons();
  8807.                       Car(new_cons) = popSTACK();
  8808.                       Cdr(new_cons) = STACK_(0+1);
  8809.                       STACK_(0+1) = new_cons;
  8810.                    }}}
  8811.                    # nΣchstes File:
  8812.                    begin_system_call();
  8813.                    if (findnext(&DTA_buffer) <0)
  8814.                      { if (!((errno==ENOENT) || (errno==ENOMORE))) { OS_error(); }
  8815.                        break; # Keine weitere Datei -> Schleifenende
  8816.                      }
  8817.                  }
  8818.              end_system_call();
  8819.              clr_break_sem_4();
  8820.             #endif
  8821.           }}
  8822.           skipSTACK(1); # next-pathname vergessen
  8823.         }}
  8824.       {# new-pathname-list wieder umdrehen:
  8825.        var reg1 object new_pathname_list = nreverse(popSTACK());
  8826.        skipSTACK(2); return new_pathname_list;
  8827.     } }
  8828.   #
  8829.   #endif # PATHNAME_EXT83
  8830.   #
  8831.   #if defined(PATHNAME_NOEXT) || defined(PATHNAME_RISCOS)
  8832.   #
  8833.   # UP: Erweitert das Directory eines Pathname um eine Komponente.
  8834.   # > STACK_1: ein Pathname
  8835.   # > STACK_0: neue Subdir-Komponente, ein Simple-String
  8836.   # < ergebnis: neuer Pathname mit um subdir verlΣngertem Directory
  8837.   # Erh÷ht STACK um 2
  8838.   # kann GC ausl÷sen
  8839.   local object pathname_add_subdir (void);
  8840.   local object pathname_add_subdir()
  8841.     { # Pathname kopieren und dessen Directory gemΣ▀
  8842.       # (append x (list y)) = (nreverse (cons y (reverse x))) verlΣngern:
  8843.       var reg2 object pathname = copy_pathname(STACK_1);
  8844.       STACK_1 = pathname;
  8845.       pushSTACK(reverse(ThePathname(pathname)->pathname_directory));
  8846.      {var reg1 object new_cons = allocate_cons();
  8847.       Cdr(new_cons) = popSTACK();
  8848.       Car(new_cons) = popSTACK();
  8849.       new_cons = nreverse(new_cons);
  8850.       pathname = popSTACK();
  8851.       ThePathname(pathname)->pathname_directory = new_cons;
  8852.       return pathname;
  8853.     }}
  8854.   #
  8855.   #if defined(UNIX) || defined(AMIGAOS) || defined(RISCOS)
  8856.   # UP: Erweitert einen Pathname um die File-Information.
  8857.   # > STACK_1: absoluter Pathname
  8858.   # > STACK_0: absoluter Pathname, Links aufgel÷st
  8859.   # > *filestatus: dessen stat-Info
  8860.   # < STACK_0: Liste (Pathname Truename Write-Date Length [Kommentar]) im :FULL-Format
  8861.   local void with_stat_info (void);
  8862.   local void with_stat_info()
  8863.     { var reg2 object new;
  8864.       #if defined(UNIX) || defined(RISCOS)
  8865.       var reg3 uintL size = filestatus->st_size;
  8866.       #endif
  8867.       #ifdef AMIGAOS
  8868.       var reg3 uintL size = filestatus->fib_Size;
  8869.       #endif
  8870.       # Pathname schon in STACK_1, als 1. Listenelement
  8871.       # Truename schon in STACK_0, als 2. Listenelement
  8872.       { var decoded_time timepoint; # Write-Date in decodierter Form
  8873.         #if defined(UNIX) || defined(RISCOS)
  8874.         convert_time(&filestatus->st_mtime,&timepoint);
  8875.         #endif
  8876.         #ifdef AMIGAOS
  8877.         convert_time(&filestatus->fib_Date,&timepoint);
  8878.         #endif
  8879.         pushSTACK(timepoint.Sekunden);
  8880.         pushSTACK(timepoint.Minuten);
  8881.         pushSTACK(timepoint.Stunden);
  8882.         pushSTACK(timepoint.Tag);
  8883.         pushSTACK(timepoint.Monat);
  8884.         pushSTACK(timepoint.Jahr);
  8885.         new = listof(6); # 6-elementige Liste bauen
  8886.       }
  8887.       pushSTACK(new); # als 3. Listenelement
  8888.       pushSTACK(UL_to_I(size)); # LΣnge als 4. Listenelement
  8889.       #if defined(UNIX) || defined(RISCOS)
  8890.       new = listof(4); # 4-elementige Liste bauen
  8891.       #endif
  8892.       #ifdef AMIGAOS
  8893.       pushSTACK(asciz_to_string(&filestatus->fib_Comment[0])); # Kommentar als 5. Listenelement
  8894.       new = listof(5); # 5-elementige Liste bauen
  8895.       #endif
  8896.       pushSTACK(Car(new)); # pathname wieder in den Stack
  8897.       pushSTACK(new); # Liste in den Stack
  8898.     }
  8899.   #endif
  8900.   #
  8901.   local object directory_search(pathname)
  8902.     var reg9 object pathname;
  8903.     {
  8904.       #ifdef PATHNAME_RISCOS
  8905.       # If we search for a file with type /= NIL, we have to interpret the last
  8906.       # subdir as the type.
  8907.       var boolean name_and_type = FALSE;
  8908.       #endif
  8909.       pathname = use_default_dir(pathname); # Default-Directory einfⁿgen
  8910.       # pathname ist jetzt neu und ein absoluter Pathname.
  8911.       pushSTACK(NIL); # result-list := NIL
  8912.       pushSTACK(pathname);
  8913.       # Falls name=NIL und type/=NIL: Setze name := "*".
  8914.       if (nullp(ThePathname(pathname)->pathname_name)
  8915.           && !nullp(ThePathname(pathname)->pathname_type)
  8916.          )
  8917.         { ThePathname(pathname)->pathname_name = O(wild_string); }
  8918.       #ifdef PATHNAME_RISCOS
  8919.       # If the name and type are both set, then make the type part of
  8920.       # the directory specification and set the new type to NIL.
  8921.       if (!nullp(ThePathname(pathname)->pathname_name)
  8922.           && !nullp(ThePathname(pathname)->pathname_type)
  8923.          )
  8924.         { name_and_type = TRUE;
  8925.           pushSTACK(pathname); pushSTACK(ThePathname(pathname)->pathname_type);
  8926.           STACK_0 = pathname = pathname_add_subdir();
  8927.           ThePathname(pathname)->pathname_type = NIL;
  8928.         }
  8929.       #endif
  8930.       # Zum Matchen: Name und Typ zu einem String zusammenfassen:
  8931.       if (nullp(ThePathname(pathname)->pathname_name))
  8932.         { pushSTACK(NIL); } # name=NIL -> auch type=NIL -> keine Files suchen
  8933.         else
  8934.         {var reg1 uintC stringcount = file_namestring_parts(pathname);
  8935.          var reg1 object nametype_string = string_concat(stringcount);
  8936.          pathname = STACK_0;
  8937.          pushSTACK(nametype_string);
  8938.         }
  8939.       pushSTACK(ThePathname(pathname)->pathname_directory); # subdir-list
  8940.       #ifdef PATHNAME_RISCOS
  8941.       STACK_0 = Cdr(STACK_0); # Liste fΣngt mit (:ABSOLUTE :ROOT ...) an, verkⁿrze sie
  8942.       #endif
  8943.       # pathname kopieren und dabei Name und Typ streichen und
  8944.       # Directory zu (:ABSOLUTE) bzw. (:ABSOLUTE :ROOT) verkⁿrzen:
  8945.       pathname = copy_pathname(pathname);
  8946.       ThePathname(pathname)->pathname_name = NIL;
  8947.       ThePathname(pathname)->pathname_type = NIL;
  8948.       ThePathname(pathname)->pathname_directory = O(directory_absolute);
  8949.       pushSTACK(pathname);
  8950.       # und in einelementige Liste packen:
  8951.       {var reg1 object new_cons = allocate_cons();
  8952.        Car(new_cons) = STACK_0;
  8953.        STACK_0 = new_cons;
  8954.       }
  8955.      {var reg7 boolean recursively = # Flag, ob die nΣchste Operation auf
  8956.         FALSE;                       # alle Subdirectories anzuwenden ist.
  8957.       loop
  8958.         # Stackaufbau: result-list, pathname, name&type, subdir-list, pathname-list.
  8959.         # result-list = Liste der fertigen Pathnames/Listen, umgedreht.
  8960.         # name&type = NIL oder Simple-String, gegen den die Filenamen zu matchen sind.
  8961.         # pathname-list = Liste der noch abzuarbeitenden Directories.
  8962.         # Dabei enthalten die Pathnames aus pathname-list das Directory
  8963.         # nur so tief, da▀ es danach mit (cdr subdir-list) weitergeht.
  8964.         { # NΣchste subdir-Ebene abarbeiten:
  8965.           STACK_1 = Cdr(STACK_1); # subdir-list verkⁿrzen
  8966.          {var reg6 signean next_task; # Was mit den Dirs aus pathname-list zu tun ist:
  8967.             # 0: nichts, fertig
  8968.             # 1: nach einem File gegebenen Namens/Typs sehen
  8969.             # -1: nach einem Subdirectory gegebenen Namens sehen
  8970.             # 2: nach allen Files suchen, die gegebenen Namen/Typ matchen
  8971.             # -2: nach allen Subdirectories suchen, die gegebenen Namen matchen
  8972.           if (matomp(STACK_1)) # subdir-list zu Ende?
  8973.             { var reg1 object nametype = STACK_2;
  8974.               if (nullp(nametype)) # name=NIL und type=NIL -> keine Files suchen
  8975.                 { next_task = 0; }
  8976.               #ifndef MSDOS
  8977.               elif (!has_wildcards(nametype))
  8978.                    # === !(has_wildcards(name) || ((!nullp(type)) && has_wildcards(type)))
  8979.                 { next_task = 1; } # File suchen
  8980.               #endif
  8981.               else
  8982.                 { next_task = 2; } # Files mit Wildcards suchen
  8983.             }
  8984.             else
  8985.             { var reg1 object next_subdir = Car(STACK_1);
  8986.               if (eq(next_subdir,S(Kwild_inferiors))) # '...' ?
  8987.                 # wird erst beim nΣchsten Durchlauf behandelt
  8988.                 { recursively = TRUE; goto passed_subdir; }
  8989.               #ifndef MSDOS
  8990.               if (
  8991.                   #ifdef PATHNAME_AMIGAOS
  8992.                   eq(next_subdir,S(Kparent)) ||
  8993.                   #endif
  8994.                   #ifdef PATHNAME_RISCOS
  8995.                   !simple_string_p(next_subdir) ||
  8996.                   #endif
  8997.                   !has_wildcards(next_subdir)
  8998.                  )
  8999.                 { next_task = -1; } # Subdir suchen
  9000.                 else
  9001.               #endif
  9002.                 { next_task = -2; } # Subdirs mit Wildcards suchen
  9003.             }
  9004.           # pathname-list durchgehen und dabei neue Liste aufbauen:
  9005.           pushSTACK(NIL);
  9006.           #ifdef UNIX
  9007.           if (!nullp(STACK_(1+5+1))) # ;CIRCLE-Flag abfragen
  9008.             { # Hash-Tabelle aller bisher abgesuchten Directories (jeweils
  9009.               # als Cons (dev . ino)) fⁿhren:
  9010.               pushSTACK(S(Ktest)); pushSTACK(S(equal));
  9011.               funcall(L(make_hash_table),2); # (MAKE-HASH-TABLE :TEST 'EQUAL)
  9012.               pushSTACK(value1);
  9013.             }
  9014.             else
  9015.             { pushSTACK(NIL); }
  9016.           #define H 1
  9017.           #else
  9018.           #define H 0
  9019.           #endif
  9020.           pushSTACK(STACK_(0+1+H));
  9021.           loop
  9022.             { # Stackaufbau: ..., new-pathname-list, [ht,] pathname-list-rest.
  9023.               var reg9 object pathname_list_rest = STACK_0;
  9024.               if (atomp(pathname_list_rest)) break;
  9025.               STACK_0 = Cdr(pathname_list_rest); # Liste verkⁿrzen
  9026.               pushSTACK(NIL); # pathnames-to-insert := NIL
  9027.               # Stackaufbau: ..., new-pathname-list, [ht,] pathname-list-rest, pathnames-to-insert.
  9028.              {var reg9 object pathname = Car(pathname_list_rest); # nΣchstes Directory
  9029.               pushSTACK(pathname); # in den Stack
  9030.               # Versuche, die Task ein wenig abzukⁿrzen:
  9031.               if (!recursively)
  9032.                 { switch (next_task)
  9033.                     { case 0: # Dieses pathname liefern
  9034.                         #ifdef UNIX
  9035.                         assure_dir_exists(FALSE); # erst noch Links aufl÷sen
  9036.                         #endif
  9037.                         # und STACK_0 vor result-list pushen:
  9038.                         {var reg1 object new_cons = allocate_cons();
  9039.                          Car(new_cons) = popSTACK();
  9040.                          Cdr(new_cons) = STACK_(4+(1+H+2));
  9041.                          STACK_(4+(1+H+2)) = new_cons;
  9042.                         }
  9043.                         goto next_pathname;
  9044.                       #ifndef MSDOS
  9045.                       case 1: # In diesem pathname nach einem File sehen
  9046.                         ThePathname(pathname)->pathname_name = # Name (/=NIL) einsetzen
  9047.                           ThePathname(STACK_(3+(1+H+2)+1))->pathname_name;
  9048.                         ThePathname(pathname)->pathname_type = # Typ einsetzen
  9049.                           ThePathname(STACK_(3+(1+H+2)+1))->pathname_type;
  9050.                         pushSTACK(pathname);
  9051.                         #ifdef PATHNAME_RISCOS
  9052.                         if (name_and_type && nullp(ThePathname(pathname)->pathname_type))
  9053.                           # Move the last subdir into the type slot of the pathname.
  9054.                           { # subdirs := (butlast subdirs) = (nreverse (cdr (reverse subdirs)))
  9055.                             var reg1 object subdirs = reverse(ThePathname(pathname)->pathname_directory);
  9056.                             pathname = STACK_0;
  9057.                             ThePathname(pathname)->pathname_type = Car(subdirs);
  9058.                             ThePathname(pathname)->pathname_directory = nreverse(Cdr(subdirs));
  9059.                           }
  9060.                         #endif
  9061.                         assure_dir_exists(FALSE); # Links aufl÷sen, File suchen
  9062.                         if (file_exists(_EMA_)) # falls File existiert
  9063.                           { if (!nullp(STACK_(0+5+(1+H+2)+2))) # :FULL gewⁿnscht?
  9064.                               { with_stat_info(); } # ja -> STACK_0 erweitern
  9065.                             # und STACK_0 vor result-list pushen:
  9066.                            {var reg1 object new_cons = allocate_cons();
  9067.                             Car(new_cons) = STACK_0;
  9068.                             Cdr(new_cons) = STACK_(4+(1+H+2)+2);
  9069.                             STACK_(4+(1+H+2)+2) = new_cons;
  9070.                           }}
  9071.                         skipSTACK(2);
  9072.                         goto next_pathname;
  9073.                       case -1: # In diesem pathname nach einem Subdirectory sehen
  9074.                         { var reg2 object namestring = assure_dir_exists(FALSE); # Links aufl÷sen, Directory-Namestring
  9075.                           pushSTACK(namestring); # Directory-Namestring
  9076.                           {var reg1 object subdir = Car(STACK_(1+(1+H+2)+1+1)); # (car subdir-list)
  9077.                            #if defined(PATHNAME_AMIGAOS) || defined(PATHNAME_RISCOS)
  9078.                            if (eq(subdir,S(Kparent))) # fⁿr Parent-Directory
  9079.                              {
  9080.                                #ifdef PATHNAME_AMIGAOS
  9081.                                pushSTACK(O(slash_string)); # zusΣtzliches "/" ans Ende
  9082.                                #endif
  9083.                                #ifdef PATHNAME_RISCOS
  9084.                                pushSTACK(O(parent_string)); # zusΣtzliches "^" ans Ende
  9085.                                #endif
  9086.                              }
  9087.                              else
  9088.                            #endif
  9089.                            pushSTACK(subdir);
  9090.                           }
  9091.                           pushSTACK(O(null_string)); # und Nullbyte
  9092.                           namestring = string_concat(3); # zusammenhΣngen
  9093.                           # Information holen:
  9094.                          #if defined(UNIX) || defined(RISCOS)
  9095.                          {var struct stat status;
  9096.                           begin_system_call();
  9097.                           if (!( stat(TheAsciz(namestring),&status) ==0))
  9098.                             { if (!(errno==ENOENT)) { OS_error(); }
  9099.                               end_system_call();
  9100.                               # Subdirectory existiert nicht -> OK.
  9101.                             }
  9102.                             else
  9103.                             # File existiert.
  9104.                             { end_system_call();
  9105.                               if (S_ISDIR(status.st_mode)) # Ist es ein Directory?
  9106.                                 # ja -> neuen Pathname dazu bilden:
  9107.                                 { # pathname kopieren und dessen Directory um
  9108.                                   # (car subdir-list) verlΣngern:
  9109.                                   pushSTACK(Car(STACK_(1+(1+H+2)+1)));
  9110.                                  {var reg1 object pathname = pathname_add_subdir();
  9111.                                   pushSTACK(pathname);
  9112.                                  }# Diesen neuen Pathname vor new-pathname-list pushen:
  9113.                                  {var reg1 object new_cons = allocate_cons();
  9114.                                   Car(new_cons) = STACK_0;
  9115.                                   Cdr(new_cons) = STACK_(H+2+1);
  9116.                                   STACK_(H+2+1) = new_cons;
  9117.                                 }}
  9118.                          }  }
  9119.                          #endif
  9120.                          #ifdef AMIGAOS
  9121.                          { var LONGALIGNTYPE(struct FileInfoBlock) fib;
  9122.                            var reg1 struct FileInfoBlock * fibptr = LONGALIGN(&fib);
  9123.                            set_break_sem_4();
  9124.                            begin_system_call();
  9125.                           {var reg2 BPTR lock = Lock(TheAsciz(namestring),ACCESS_READ);
  9126.                            if (lock==BPTR_NULL)
  9127.                              { if (!(IoErr()==ERROR_OBJECT_NOT_FOUND)) { OS_error(); }
  9128.                                end_system_call();
  9129.                                clr_break_sem_4();
  9130.                                # Subdirectory existiert nicht -> OK.
  9131.                              }
  9132.                              else
  9133.                              # File existiert.
  9134.                              { if (! Examine(lock,fibptr) ) { UnLock(lock); OS_error(); }
  9135.                                UnLock(lock);
  9136.                                end_system_call();
  9137.                                clr_break_sem_4();
  9138.                                if (fibptr->fib_DirEntryType > 0) # Ist es ein Directory?
  9139.                                  # ja -> neuen Pathname dazu bilden:
  9140.                                  { # pathname kopieren und dessen Directory um
  9141.                                    # (car subdir-list) verlΣngern:
  9142.                                    pushSTACK(Car(STACK_(1+(1+H+2)+1)));
  9143.                                   {var reg1 object pathname = pathname_add_subdir();
  9144.                                    pushSTACK(pathname);
  9145.                                   }# Diesen neuen Pathname vor new-pathname-list pushen:
  9146.                                   {var reg1 object new_cons = allocate_cons();
  9147.                                    Car(new_cons) = STACK_0;
  9148.                                    Cdr(new_cons) = STACK_(H+2+1);
  9149.                                    STACK_(H+2+1) = new_cons;
  9150.                                  }}
  9151.                          }}  }
  9152.                          #endif
  9153.                         }
  9154.                         skipSTACK(1);
  9155.                         goto next_pathname;
  9156.                         #endif
  9157.                 }   }
  9158.               # Um die Task zu erledigen, mⁿssen alle EintrΣge dieses
  9159.               # Directory abgesucht werden:
  9160.               {{var reg1 object dir_namestring = assure_dir_exists(FALSE); # Links aufl÷sen, Directory-Name bilden
  9161.                 pushSTACK(dir_namestring); # retten
  9162.                }# Stackaufbau: ..., pathname, dir_namestring.
  9163.                #ifdef UNIX
  9164.                 if (!nullp(STACK_(1+5+(1+H+2)+2))) # ;CIRCLE-Flag abfragen
  9165.                   { # pathname in der Hash-Tabelle suchen:
  9166.                     pushSTACK(STACK_0); # Directory-Name
  9167.                     pushSTACK(O(punkt_string)); # und "."
  9168.                     pushSTACK(O(null_string)); # und Nullbyte
  9169.                     {var reg8 object namestring = string_concat(3); # zusammenhΣngen
  9170.                      var struct stat status;
  9171.                      begin_system_call();
  9172.                      if (!( stat(TheAsciz(namestring),&status) ==0)) # Information holen
  9173.                        { if (!(errno==ENOENT)) { OS_error(); }
  9174.                          end_system_call();
  9175.                          # Eintrag existiert doch nicht (das kann uns
  9176.                          # wohl nur bei symbolischen Links passieren)
  9177.                          # -> wird ⁿbergangen
  9178.                          skipSTACK(2); goto next_pathname;
  9179.                        }
  9180.                      end_system_call();
  9181.                      # Eintrag existiert (welch Wunder...)
  9182.                      pushSTACK(UL_to_I(status.st_dev)); # Device-Nummer und
  9183.                      pushSTACK(UL_to_I(status.st_ino)); # Inode-Nummer
  9184.                      {var reg1 object new_cons = allocate_cons(); # zusammenconsen
  9185.                       Cdr(new_cons) = popSTACK(); Car(new_cons) = popSTACK();
  9186.                       # und in der Hash-Tabelle aufsuchen und ablegen:
  9187.                       if (!nullp(shifthash(STACK_(2+2),new_cons,T)))
  9188.                         # war schon drin -> wird ⁿbergangen
  9189.                         { skipSTACK(2); goto next_pathname; }
  9190.                   } }}
  9191.                #endif
  9192.                 if (next_task==0)
  9193.                   # Pathname STACK_1 vor result-list pushen:
  9194.                   {var reg1 object new_cons = allocate_cons();
  9195.                    Car(new_cons) = STACK_1;
  9196.                    Cdr(new_cons) = STACK_(4+(1+H+2)+2);
  9197.                    STACK_(4+(1+H+2)+2) = new_cons;
  9198.                   }
  9199.                #if defined(UNIX) || defined(RISCOS)
  9200.                { var reg8 object namestring;
  9201.                  #ifdef UNIX
  9202.                  pushSTACK(STACK_0); # Directory-Name
  9203.                  pushSTACK(O(punkt_string)); # und "."
  9204.                  pushSTACK(O(null_string)); # und Nullbyte
  9205.                  namestring = string_concat(3); # zusammenhΣngen
  9206.                  #endif
  9207.                  #ifdef RISCOS
  9208.                  var reg10 object wildcard_mask;
  9209.                  namestring = copy_string(STACK_0); # Directory-Name
  9210.                  TheSstring(namestring)->data[TheSstring(namestring)->length-1] = '\0'; # mit Nullbyte statt '.' am Schlu▀
  9211.                  # Statt wildcard_match() selber aufzurufen, ⁿberlassen wir das dem Betriebssystem:
  9212.                  pushSTACK(namestring); # retten
  9213.                  wildcard_mask = string_to_asciz(next_task<0 ? Car(STACK_(1+(1+H+2)+3)) : STACK_(2+(1+H+2)+3));
  9214.                  # In wildcard_mask die Wildchar-Characters '?' ins synonyme '#' umwandeln:
  9215.                  { var reg1 uintB* ptr = &TheSstring(wildcard_mask)->data[0];
  9216.                    var reg2 uintL count = TheSstring(wildcard_mask)->length;
  9217.                    dotimespL(count,count, { if (*ptr == '?') { *ptr = '#'; } ptr++; } );
  9218.                  }
  9219.                  namestring = popSTACK();
  9220.                  #endif
  9221.                  # Directory absuchen:
  9222.                 {var reg5 DIR* dirp;
  9223.                  set_break_sem_4();
  9224.                  begin_system_call();
  9225.                  #ifdef UNIX
  9226.                  dirp = opendir(TheAsciz(namestring)); # Directory ÷ffnen
  9227.                  #endif
  9228.                  #ifdef RISCOS
  9229.                  dirp = opendir(TheAsciz(namestring),TheAsciz(wildcard_mask)); # Directory zum Suchen ÷ffnen
  9230.                  #endif
  9231.                  if (dirp == (DIR*)NULL) { OS_error(); }
  9232.                  end_system_call();
  9233.                  loop
  9234.                    { var reg2 SDIRENT* dp;
  9235.                      errno = 0;
  9236.                      begin_system_call();
  9237.                      dp = readdir(dirp); # nΣchsten Directory-Eintrag holen
  9238.                      end_system_call();
  9239.                      if (dp == (SDIRENT*)NULL) # Error oder Directory zu Ende
  9240.                        { if (!(errno==0)) { OS_error(); } else break; }
  9241.                      # Directory-Eintrag in String umwandeln:
  9242.                     {var reg4 object direntry;
  9243.                      {var reg3 uintL direntry_len;
  9244.                       #ifdef DIRENT_WITHOUT_NAMLEN
  9245.                       # Unter UNIX_LINUX reicht direntry_len := dp->d_reclen, aber i.a. ist
  9246.                       # direntry_len := min(dp->d_reclen,asciz_length(dp->d_name))  n÷tig:
  9247.                       {var reg1 const uintB* ptr = (const uintB*)(&dp->d_name[0]);
  9248.                        var reg1 uintL count;
  9249.                        direntry_len = 0;
  9250.                        dotimesL(count,dp->d_reclen,
  9251.                          { if (*ptr == '\0') break;
  9252.                            ptr++; direntry_len++;
  9253.                          });
  9254.                       }
  9255.                       #else
  9256.                       direntry_len = dp->d_namlen;
  9257.                       #endif
  9258.                       direntry = make_string((const uintB*)(&dp->d_name[0]),direntry_len);
  9259.                      }
  9260.                      #ifndef RISCOS
  9261.                      # "." und ".." ⁿbergehen:
  9262.                      if (!(equal(direntry,O(punkt_string))
  9263.                            || equal(direntry,O(punktpunkt_string))
  9264.                         ) )
  9265.                      #endif
  9266.                        { pushSTACK(direntry);
  9267.                          # Stackaufbau: ..., pathname, dir_namestring, direntry.
  9268.                          # Feststellen, ob es ein Directory oder ein File ist:
  9269.                          pushSTACK(STACK_1); # Directory-Namestring
  9270.                          pushSTACK(direntry); # direntry
  9271.                          pushSTACK(O(null_string)); # und Nullbyte
  9272.                         {var reg3 object namestring = string_concat(3); # zusammenhΣngen
  9273.                          # Information holen:
  9274.                          var struct stat status;
  9275.                          begin_system_call();
  9276.                          if (!( stat(TheAsciz(namestring),&status) ==0))
  9277.                            { if (!(errno==ENOENT)) { OS_error(); }
  9278.                              end_system_call();
  9279.                              # Eintrag existiert doch nicht (das kann uns
  9280.                              # wohl nur bei symbolischen Links passieren)
  9281.                              # -> wird ⁿbergangen
  9282.                            }
  9283.                            else
  9284.                            { end_system_call();
  9285.                              # Eintrag existiert (welch Wunder...)
  9286.                              if (S_ISDIR(status.st_mode)) # Ist es ein Directory?
  9287.                                # Eintrag ist ein Directory.
  9288.                                { if (recursively) # alle rekursiven Subdirectories gewⁿnscht?
  9289.                                    # ja -> zu einem Pathname machen und auf
  9290.                                    # pathnames-to-insert pushen (wird nachher
  9291.                                    # vor pathname-list-rest eingefⁿgt):
  9292.                                    { pushSTACK(STACK_2); pushSTACK(STACK_(0+1)); # pathname und direntry
  9293.                                     {var reg1 object pathname = pathname_add_subdir();
  9294.                                      pushSTACK(pathname);
  9295.                                     }# Diesen neuen Pathname vor pathname-to-insert pushen:
  9296.                                     {var reg1 object new_cons = allocate_cons();
  9297.                                      Car(new_cons) = popSTACK();
  9298.                                      Cdr(new_cons) = STACK_(0+3);
  9299.                                      STACK_(0+3) = new_cons;
  9300.                                    }}
  9301.                                  if (next_task<0)
  9302.                                    {
  9303.                                      #ifndef RISCOS
  9304.                                      # (car subdir-list) mit direntry matchen:
  9305.                                      if (wildcard_match(Car(STACK_(1+(1+H+2)+3)),STACK_0))
  9306.                                      #endif
  9307.                                        # Subdirectory matcht -> zu einem Pathname
  9308.                                        # machen und auf new-pathname-list pushen:
  9309.                                        { pushSTACK(STACK_2); pushSTACK(STACK_(0+1)); # pathname und direntry
  9310.                                         {var reg1 object pathname = pathname_add_subdir();
  9311.                                          pushSTACK(pathname);
  9312.                                         }# Diesen neuen Pathname vor new-pathname-list pushen:
  9313.                                         {var reg1 object new_cons = allocate_cons();
  9314.                                          Car(new_cons) = popSTACK();
  9315.                                          Cdr(new_cons) = STACK_(H+2+3);
  9316.                                          STACK_(H+2+3) = new_cons;
  9317.                                    }   }}
  9318.                                }
  9319.                                else
  9320.                                # Eintrag ist ein (halbwegs) normales File.
  9321.                                { if (next_task>0)
  9322.                                    {
  9323.                                      #ifndef RISCOS
  9324.                                      # name&type mit direntry matchen:
  9325.                                      if (wildcard_match(STACK_(2+(1+H+2)+3),STACK_0))
  9326.                                      #endif
  9327.                                        # File matcht -> zu einem Pathname machen
  9328.                                        # und auf result-list pushen:
  9329.                                        {
  9330.                                          #ifndef PATHNAME_RISCOS
  9331.                                          pushSTACK(STACK_0); # direntry
  9332.                                          split_name_type(1); # in Name und Typ aufspalten
  9333.                                          {var reg1 object pathname = copy_pathname(STACK_(2+2));
  9334.                                           ThePathname(pathname)->pathname_type = popSTACK(); # Typ einsetzen
  9335.                                           ThePathname(pathname)->pathname_name = popSTACK(); # Name einsetzen
  9336.                                           pushSTACK(pathname);
  9337.                                           pushSTACK(pathname);
  9338.                                          }
  9339.                                          #else # PATHNAME_RISCOS
  9340.                                          {var reg1 object pathname = copy_pathname(STACK_2);
  9341.                                           pushSTACK(pathname);
  9342.                                           if (name_and_type && nullp(ThePathname(pathname)->pathname_type))
  9343.                                             # Move the last subdir into the type slot of the pathname.
  9344.                                             { # subdirs := (butlast subdirs) = (nreverse (cdr (reverse subdirs)))
  9345.                                               var reg1 object subdirs = reverse(ThePathname(pathname)->pathname_directory);
  9346.                                               pathname = STACK_0;
  9347.                                               ThePathname(pathname)->pathname_type = Car(subdirs);
  9348.                                               ThePathname(pathname)->pathname_directory = nreverse(Cdr(subdirs));
  9349.                                             }
  9350.                                           ThePathname(pathname)->pathname_name = STACK_1; # direntry
  9351.                                           pushSTACK(pathname);
  9352.                                          }
  9353.                                          #endif
  9354.                                          # Truename bilden (symbolische Links aufl÷sen):
  9355.                                          assure_dir_exists(FALSE);
  9356.                                          if (file_exists(_EMA_)) # falls File (immer noch...) existiert
  9357.                                            { if (!nullp(STACK_(0+5+(1+H+2)+3+2))) # :FULL gewⁿnscht?
  9358.                                                with_stat_info(); # ja -> STACK_0 erweitern
  9359.                                              # und STACK_0 vor result-list pushen:
  9360.                                             {var reg1 object new_cons = allocate_cons();
  9361.                                              Car(new_cons) = STACK_0;
  9362.                                              Cdr(new_cons) = STACK_(4+(1+H+2)+3+2);
  9363.                                              STACK_(4+(1+H+2)+3+2) = new_cons;
  9364.                                            }}
  9365.                                          skipSTACK(2);
  9366.                                    }   }
  9367.                            }   }
  9368.                          skipSTACK(1); # direntry vergessen
  9369.                    }}  }}
  9370.                  begin_system_call();
  9371.                  if (CLOSEDIR(dirp)) { OS_error(); }
  9372.                  end_system_call();
  9373.                  clr_break_sem_4();
  9374.                }}
  9375.                #endif
  9376.                #ifdef AMIGAOS
  9377.                 # Directory absuchen:
  9378.                { var reg7 object namestring = OSnamestring(STACK_0);
  9379.                  set_break_sem_4();
  9380.                  begin_system_call();
  9381.                 {var reg6 BPTR lock = Lock(TheAsciz(namestring),ACCESS_READ);
  9382.                  var LONGALIGNTYPE(struct FileInfoBlock) fib;
  9383.                  var reg5 struct FileInfoBlock * fibptr = LONGALIGN(&fib);
  9384.                  if (lock==BPTR_NULL) { OS_error(); }
  9385.                  if (! Examine(lock,fibptr) ) { OS_error(); }
  9386.                  end_system_call();
  9387.                  loop
  9388.                    { begin_system_call();
  9389.                      if (! ExNext(lock,fibptr) ) # Error oder Directory zu Ende?
  9390.                        break;
  9391.                      end_system_call();
  9392.                      # Directory-Eintrag in String umwandeln:
  9393.                     {var reg4 object direntry = asciz_to_string(&fibptr->fib_FileName[0]);
  9394.                      pushSTACK(direntry);
  9395.                      # Stackaufbau: ..., pathname, dir_namestring, direntry.
  9396.                      # Feststellen, ob es ein Directory oder ein File ist:
  9397.                      if (fibptr->fib_DirEntryType > 0) # Ist es ein Directory?
  9398.                        # Eintrag ist ein Directory.
  9399.                        { if (recursively) # alle rekursiven Subdirectories gewⁿnscht?
  9400.                            # ja -> zu einem Pathname machen und auf
  9401.                            # pathnames-to-insert pushen (wird nachher
  9402.                            # vor pathname-list-rest eingefⁿgt):
  9403.                            { pushSTACK(STACK_2); pushSTACK(STACK_(0+1)); # pathname und direntry
  9404.                             {var reg1 object pathname = pathname_add_subdir();
  9405.                              pushSTACK(pathname);
  9406.                             }# Diesen neuen Pathname vor pathname-to-insert pushen:
  9407.                             {var reg1 object new_cons = allocate_cons();
  9408.                              Car(new_cons) = popSTACK();
  9409.                              Cdr(new_cons) = STACK_(0+3);
  9410.                              STACK_(0+3) = new_cons;
  9411.                            }}
  9412.                          if (next_task<0)
  9413.                            { # (car subdir-list) mit direntry matchen:
  9414.                              if (wildcard_match(Car(STACK_(1+(1+H+2)+3)),STACK_0))
  9415.                                # Subdirectory matcht -> zu einem Pathname
  9416.                                # machen und auf new-pathname-list pushen:
  9417.                                { pushSTACK(STACK_2); pushSTACK(STACK_(0+1)); # pathname und direntry
  9418.                                 {var reg1 object pathname = pathname_add_subdir();
  9419.                                  pushSTACK(pathname);
  9420.                                 }# Diesen neuen Pathname vor new-pathname-list pushen:
  9421.                                 {var reg1 object new_cons = allocate_cons();
  9422.                                  Car(new_cons) = popSTACK();
  9423.                                  Cdr(new_cons) = STACK_(H+2+3);
  9424.                                  STACK_(H+2+3) = new_cons;
  9425.                            }   }}
  9426.                        }
  9427.                        else
  9428.                        # Eintrag ist ein (halbwegs) normales File.
  9429.                        { if (next_task>0)
  9430.                            { # name&type mit direntry matchen:
  9431.                              if (wildcard_match(STACK_(2+(1+H+2)+3),STACK_0))
  9432.                                # File matcht -> zu einem Pathname machen
  9433.                                # und auf result-list pushen:
  9434.                                { pushSTACK(STACK_0); # direntry
  9435.                                  split_name_type(1); # in Name und Typ aufspalten
  9436.                                 {var reg1 object pathname = copy_pathname(STACK_(2+2));
  9437.                                  ThePathname(pathname)->pathname_type = popSTACK(); # Typ einsetzen
  9438.                                  ThePathname(pathname)->pathname_name = popSTACK(); # Name einsetzen
  9439.                                  pushSTACK(pathname);
  9440.                                  pushSTACK(pathname);
  9441.                                 }
  9442.                                 assure_dir_exists(FALSE); # Truename bilden (symbolische Links aufl÷sen)
  9443.                                 { if (!nullp(STACK_(0+5+(1+H+2)+3+2))) # :FULL gewⁿnscht?
  9444.                                     with_stat_info(); # ja -> STACK_0 erweitern
  9445.                                   # und STACK_0 vor result-list pushen:
  9446.                                  {var reg1 object new_cons = allocate_cons();
  9447.                                   Car(new_cons) = STACK_0;
  9448.                                   Cdr(new_cons) = STACK_(4+(1+H+2)+3+2);
  9449.                                   STACK_(4+(1+H+2)+3+2) = new_cons;
  9450.                                 }}
  9451.                                 skipSTACK(2);
  9452.                        }   }   }
  9453.                      skipSTACK(1); # direntry vergessen
  9454.                    }}
  9455.                  UnLock(lock);
  9456.                  if (!(IoErr()==ERROR_NO_MORE_ENTRIES)) { OS_error(); }
  9457.                  end_system_call();
  9458.                  clr_break_sem_4();
  9459.                }}
  9460.                #endif
  9461.                #ifdef MSDOS
  9462.                 pushSTACK(STACK_0); # Directory-Name
  9463.                 pushSTACK(O(wild_wild_string)); # und "*.*"
  9464.                 pushSTACK(O(null_string)); # und Nullbyte
  9465.                {var reg8 object namestring = string_concat(3); # zusammenhΣngen
  9466.                 # Directory absuchen, gemΣ▀ DOS-Konvention:
  9467.                 var struct ffblk DTA_buffer;
  9468.                 set_break_sem_4(); # wegen DTA-Buffer gegen Unterbrechungen sperren
  9469.                 # Suchanfang, suche nach Ordnern und normalen Dateien:
  9470.                 begin_system_call();
  9471.                 if (findfirst(TheAsciz(namestring),&DTA_buffer,FA_DIREC|FA_ARCH|FA_RDONLY) <0)
  9472.                   { if (!((errno==ENOENT) || (errno==ENOMORE))) { OS_error(); } }
  9473.                   else # Keine Datei gefunden -> Schleife nicht durchlaufen
  9474.                   loop
  9475.                     { end_system_call();
  9476.                      {# Directory-Eintrag in String umwandeln:
  9477.                       var reg4 object direntry = asciz_to_string(&DTA_buffer.ff_name[0]);
  9478.                       # "." und ".." ⁿbergehen:
  9479.                       if (!(equal(direntry,O(punkt_string))
  9480.                             || equal(direntry,O(punktpunkt_string))
  9481.                          ) )
  9482.                         { pushSTACK(direntry);
  9483.                           # Stackaufbau: ..., pathname, dir_namestring, direntry.
  9484.                           if (DTA_buffer.ff_attrib & FA_DIREC) # Ist es ein Directory?
  9485.                             # Eintrag ist ein Directory.
  9486.                             { if (recursively) # alle rekursiven Subdirectories gewⁿnscht?
  9487.                                 # ja -> zu einem Pathname machen und auf
  9488.                                 # pathnames-to-insert pushen (wird nachher
  9489.                                 # vor pathname-list-rest eingefⁿgt):
  9490.                                 { pushSTACK(STACK_2); pushSTACK(STACK_(0+1)); # pathname und direntry
  9491.                                  {var reg1 object pathname = pathname_add_subdir();
  9492.                                   pushSTACK(pathname);
  9493.                                  }# Diesen neuen Pathname vor pathname-to-insert pushen:
  9494.                                  {var reg1 object new_cons = allocate_cons();
  9495.                                   Car(new_cons) = popSTACK();
  9496.                                   Cdr(new_cons) = STACK_(0+3);
  9497.                                   STACK_(0+3) = new_cons;
  9498.                                 }}
  9499.                               if (next_task<0)
  9500.                                 { # (car subdir-list) mit direntry matchen:
  9501.                                   if (wildcard_match(Car(STACK_(1+(1+H+2)+3)),STACK_0))
  9502.                                     # Subdirectory matcht -> zu einem Pathname
  9503.                                     # machen und auf new-pathname-list pushen:
  9504.                                     { pushSTACK(STACK_2); pushSTACK(STACK_(0+1)); # pathname und direntry
  9505.                                      {var reg1 object pathname = pathname_add_subdir();
  9506.                                       pushSTACK(pathname);
  9507.                                      }# Diesen neuen Pathname vor new-pathname-list pushen:
  9508.                                      {var reg1 object new_cons = allocate_cons();
  9509.                                       Car(new_cons) = popSTACK();
  9510.                                       Cdr(new_cons) = STACK_(H+2+3);
  9511.                                       STACK_(H+2+3) = new_cons;
  9512.                                 }   }}
  9513.                             }
  9514.                             else
  9515.                             # Eintrag ist ein (halbwegs) normales File.
  9516.                             { if (next_task>0)
  9517.                                 { # name&type mit direntry matchen:
  9518.                                   if (wildcard_match(STACK_(2+(1+H+2)+3),STACK_0))
  9519.                                     # File matcht -> zu einem Pathname machen
  9520.                                     # und auf result-list pushen:
  9521.                                     { pushSTACK(STACK_0); # direntry
  9522.                                       split_name_type(1); # in Name und Typ aufspalten
  9523.                                      {var reg1 object new = copy_pathname(STACK_(2+2));
  9524.                                       ThePathname(new)->pathname_type = popSTACK(); # Typ einsetzen
  9525.                                       ThePathname(new)->pathname_name = popSTACK(); # Name einsetzen
  9526.                                       # Full-Flag abtesten und evtl. mehr Information besorgen:
  9527.                                       if (!nullp(STACK_(0+5+(1+H+2)+3))) # :FULL gewⁿnscht?
  9528.                                         { pushSTACK(new); # newpathname als 1. Listenelement
  9529.                                           pushSTACK(new); # newpathname als 2. Listenelement
  9530.                                           { # Uhrzeit und Datum von DOS-Format in Decoded-Time umwandeln:
  9531.                                             var decoded_time timepoint;
  9532.                                             convert_timedate((uintW)DTA_buffer.ff_ftime,(uintW)DTA_buffer.ff_fdate,
  9533.                                                              &timepoint);
  9534.                                             pushSTACK(timepoint.Sekunden);
  9535.                                             pushSTACK(timepoint.Minuten);
  9536.                                             pushSTACK(timepoint.Stunden);
  9537.                                             pushSTACK(timepoint.Tag);
  9538.                                             pushSTACK(timepoint.Monat);
  9539.                                             pushSTACK(timepoint.Jahr);
  9540.                                             new = listof(6); # 6-elementige Liste bauen
  9541.                                           }
  9542.                                           pushSTACK(new); # als 3. Listenelement
  9543.                                           pushSTACK(UL_to_I(*(uintL*)(&DTA_buffer.ff_fsize))); # LΣnge als 4. Listenelement
  9544.                                           new = listof(4); # 4-elementige Liste bauen
  9545.                                         }
  9546.                                       pushSTACK(new);
  9547.                                      }# und STACK_0 vor result-list pushen:
  9548.                                      {var reg1 object new_cons = allocate_cons();
  9549.                                       Car(new_cons) = popSTACK();
  9550.                                       Cdr(new_cons) = STACK_(4+(1+H+2)+3);
  9551.                                       STACK_(4+(1+H+2)+3) = new_cons;
  9552.                             }   }   }}
  9553.                           skipSTACK(1); # direntry vergessen
  9554.                         }
  9555.                       # nΣchstes File:
  9556.                       begin_system_call();
  9557.                       if (findnext(&DTA_buffer) <0)
  9558.                         { if (!((errno==ENOENT) || (errno==ENOMORE))) { OS_error(); }
  9559.                           break; # Keine weitere Datei -> Schleifenende
  9560.                         }
  9561.                     }}
  9562.                 end_system_call();
  9563.                 clr_break_sem_4();
  9564.                }
  9565.                #endif
  9566.               }
  9567.               skipSTACK(2); # pathname und dir-namestring vergessen
  9568.               next_pathname: ;
  9569.              }# Stackaufbau: ..., new-pathname-list, [ht,] pathname-list-rest, pathnames-to-insert.
  9570.               # Vor dem Weiterrⁿcken mit pathname-list-rest :
  9571.               # pathname-list-rest := (nreconc pathnames-to-insert pathname-list-rest) :
  9572.              {var reg1 object pathnames_to_insert = popSTACK();
  9573.               STACK_0 = nreconc(pathnames_to_insert,STACK_0);
  9574.             }}
  9575.           skipSTACK(H+1); # leere pathname-list-rest und evtl. Hash-Tabelle vergessen
  9576.           #undef H
  9577.           # new-pathname-list umdrehen, ersetzt die geleerte pathname-list:
  9578.           {var reg1 object new_pathname_list = popSTACK();
  9579.            STACK_0 = nreverse(new_pathname_list); # neue pathname-list
  9580.           }
  9581.           # Mit dieser Subdir-Stufe sind wir fertig.
  9582.           if (matomp(STACK_1)) break; # (atom subdir-list) -> fertig.
  9583.           recursively = FALSE; # die nΣchste (vorlΣufig) nicht-rekursiv
  9584.           passed_subdir: ;
  9585.         }}
  9586.       # Stackaufbau: result-list, pathname, name&type, subdir-list, pathname-list.
  9587.       # subdir-list ist =NIL geworden, auch pathname-list = NIL (denn beim
  9588.       # letzten Schleifendurchlauf ist immer next_task=0,1,2, und dadurch
  9589.       # wurde nichts auf new-pathname-list gepusht).
  9590.       skipSTACK(4);
  9591.       return popSTACK(); # result-list als Ergebnis
  9592.     }}
  9593.   #
  9594.   #endif # PATHNAME_NOEXT
  9595.  
  9596. LISPFUN(directory,0,1,norest,key,2, (kw(circle),kw(full)) )
  9597. # (DIRECTORY [pathname [:circle] [:full]]), CLTL S. 427
  9598.   { # Stackaufbau: pathname, circle, full.
  9599.     #ifdef UNIX
  9600.     # :CIRCLE-Argument hat Defaultwert NIL:
  9601.     if (eq(STACK_1,unbound)) { STACK_1 = NIL; }
  9602.     #endif
  9603.     # :FULL-Argument hat Defaultwert NIL:
  9604.     if (eq(STACK_0,unbound)) { STACK_0 = NIL; }
  9605.     # Pathname-Argument ⁿberprⁿfen:
  9606.    {var reg1 object pathname = STACK_2;
  9607.     if (eq(pathname,unbound))
  9608.       {
  9609.         #ifdef PATHNAME_EXT83
  9610.         pathname = O(wild_wild_string); # Default ist "*.*" bzw. "*.*;*"
  9611.         #endif
  9612.         #if defined(PATHNAME_NOEXT) || defined(PATHNAME_RISCOS)
  9613.         pathname = O(wild_string); # Default ist "*"
  9614.         #endif
  9615.       }
  9616.     pathname = coerce_pathname(pathname); # zu einem Pathname machen
  9617.     # Los geht's:
  9618.     #ifdef PATHNAME_ATARI
  9619.     if (eq(ThePathname(pathname)->pathname_device,S(Kwild))) # Device = :WILD ?
  9620.       # alle Devices abzusuchen
  9621.       { STACK_2 = pathname;
  9622.         pushSTACK(O(drive_alist)); # Aliste aller Drives
  9623.         pushSTACK(NIL); # bisherige Pathname-Liste := NIL
  9624.         pushSTACK(STACK_(0+2)); # full (fⁿr directory_search)
  9625.         # Stackaufbau: pathname, circle, full, Drive-Alist, pathname-list, full.
  9626.         while (mconsp(STACK_2)) # alle Drives durchlaufen
  9627.           { var reg3 object newpathname = copy_pathname(STACK_(2+3)); # Pathname kopieren
  9628.            {var reg2 object alistr = STACK_2; # restliche Drive-Aliste
  9629.             STACK_2 = Cdr(alistr); # verkⁿrzen
  9630.             alistr = Car(alistr); # Alisteneintrag
  9631.             ThePathname(newpathname)->pathname_device = Car(alistr); # Drive ⁿbernehmen
  9632.            }# innerhalb eines Laufwerks suchen:
  9633.            {var reg2 object newpathnames = directory_search(newpathname);
  9634.             # und Pathname-Liste vor STACK_1 hΣngen:
  9635.             STACK_1 = nreconc(newpathnames,STACK_1);
  9636.           }}
  9637.         value1 = nreverse(STACK_1); # Pathname-Liste wieder umdrehen
  9638.         skipSTACK(3+3);
  9639.       }
  9640.       else
  9641.       # nur ein Device abzusuchen
  9642.     #endif
  9643.     #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  9644.     if (eq(ThePathname(pathname)->pathname_device,S(Kwild))) # Device = :WILD ?
  9645.       # alle Devices abzusuchen
  9646.       { STACK_2 = pathname;
  9647.         pushSTACK(NIL); # bisherige Pathname-Liste := NIL
  9648.         pushSTACK(STACK_(0+1)); # full (fⁿr directory_search)
  9649.         # Stackaufbau: pathname, circle, full, pathname-list, full.
  9650.         {var uintB drive;
  9651.          for (drive='A'; drive<='Z'; drive++) # alle Drives durchlaufen
  9652.            if (good_drive(drive))
  9653.              { pushSTACK(make_string(&drive,1)); # Device, einelementiger String
  9654.               {var reg2 object newpathname = copy_pathname(STACK_(2+2+1)); # Pathname kopieren
  9655.                ThePathname(newpathname)->pathname_device = popSTACK(); # Drive ⁿbernehmen
  9656.                # innerhalb eines Laufwerks suchen:
  9657.                {var reg3 object newpathnames = directory_search(newpathname);
  9658.                 # und Pathname-Liste vor STACK_1 hΣngen:
  9659.                 STACK_1 = nreconc(newpathnames,STACK_1);
  9660.         }    }}}
  9661.         value1 = nreverse(STACK_1); # Pathname-Liste wieder umdrehen
  9662.         skipSTACK(3+2);
  9663.       }
  9664.       else
  9665.       # nur ein Device abzusuchen
  9666.     #endif
  9667.       { value1 = directory_search(pathname); # matchende Pathnames bilden
  9668.         skipSTACK(3);
  9669.       }
  9670.     mv_count=1;
  9671.   }}
  9672.  
  9673. LISPFUN(cd,0,1,norest,nokey,0,NIL)
  9674. # (CD [pathname]) setzt das aktuelle Laufwerk und das aktuelle Directory.
  9675.   { var reg1 object pathname = popSTACK();
  9676.     if (eq(pathname,unbound)) { pathname = O(leer_string); } # "" als Default
  9677.     pathname = coerce_pathname(pathname); # zu einem Pathname machen
  9678.     # kopieren und Name und Typ auf NIL setzen:
  9679.     pathname = copy_pathname(pathname);
  9680.     ThePathname(pathname)->pathname_name = NIL;
  9681.     ThePathname(pathname)->pathname_type = NIL;
  9682.     check_no_wildcards(pathname); # mit Wildcards -> Fehler
  9683.     pathname = use_default_dir(pathname); # Pathname mit Seriennummer draus machen
  9684.     pushSTACK(pathname);
  9685.     assure_dir_exists(FALSE); # Directory mu▀ existieren
  9686.     change_default(); # Default-Drive, Default-Directory setzen
  9687.     value1 = popSTACK(); mv_count=1; # neuer pathname als Wert
  9688.   }
  9689.  
  9690. # UP: ▄berprⁿft ein Pathname-Argument, ob Name und Typ beide =NIL sind,
  9691. # und ob das Directory "fast" existiert.
  9692. # shorter_directory_arg()
  9693. # > STACK_0 : Pathname-Argument
  9694. #if defined(ATARI) || defined(MSDOS)
  9695. # < ergebnis: Directory-Namestring (fⁿr DOS, ASCIZ, ohne '\' am Schlu▀)
  9696. #endif
  9697. #if defined(UNIX) || defined(AMIGAOS)
  9698. # < ergebnis: Directory-Namestring (fⁿrs OS, ASCIZ, ohne '/' am Schlu▀)
  9699. #endif
  9700. #if defined(RISCOS)
  9701. # < ergebnis: Directory-Namestring (fⁿrs OS, ASCIZ, ohne '.' am Schlu▀)
  9702. #endif
  9703. # Erh÷ht STACK um 1.
  9704. # kann GC ausl÷sen
  9705.   local object shorter_directory_arg (void);
  9706.   local object shorter_directory_arg()
  9707.     { var reg1 object pathname = coerce_pathname(popSTACK()); # Argument zu einem Pathname machen
  9708.       check_no_wildcards(pathname); # mit Wildcards -> Fehler
  9709.       pathname = use_default_dir(pathname); # Default-Directory einfⁿgen
  9710.       # ▄berprⁿfe, ob Name=NIL und Typ=NIL :
  9711.       if (!(nullp(ThePathname(pathname)->pathname_name)
  9712.             && nullp(ThePathname(pathname)->pathname_type)
  9713.          ) )
  9714.         { pushSTACK(pathname); # Wert fⁿr Slot PATHNAME von FILE-ERROR
  9715.           pushSTACK(pathname);
  9716.           fehler(file_error,
  9717.                  DEUTSCH ? "Das ist keine Directory-Angabe: ~" :
  9718.                  ENGLISH ? "not a directory: ~" :
  9719.                  FRANCAIS ? "Ceci ne dΘsigne pas un rΘpertoire : ~" :
  9720.                  ""
  9721.                 );
  9722.         }
  9723.       pushSTACK(pathname); # neuen Pathname retten
  9724.       # verkⁿrze das Directory:
  9725.       {var reg2 object subdirs = ThePathname(pathname)->pathname_directory;
  9726.        #if HAS_SERNR
  9727.        if (nullp(Cdr(Cdr(subdirs)))) # Root-Directory ?
  9728.        #else
  9729.        if (nullp(Cdr(subdirs))) # Root-Directory ?
  9730.        #endif
  9731.          { baddir:
  9732.            # STACK_0 = pathname, Wert fⁿr Slot PATHNAME von FILE-ERROR
  9733.            pushSTACK(STACK_0);
  9734.            fehler(file_error,
  9735.                   DEUTSCH ? "Hier sind nur echte Unterdirectories zulΣssig, nicht ~" :
  9736.                   ENGLISH ? "root directory not allowed here: ~" :
  9737.                   FRANCAIS ? "Le rΘpertoire racine n'est pas permis ici : ~" :
  9738.                   ""
  9739.                  );
  9740.          }
  9741.        subdirs = reverse(subdirs); # Liste kopieren und dabei umdrehen
  9742.        #if defined(PATHNAME_AMIGAOS) || defined(PATHNAME_RISCOS)
  9743.        if (eq(Car(subdirs),S(Kparent))) # letztes Subdir mu▀ /= :PARENT sein
  9744.          goto baddir;
  9745.        #endif
  9746.        pushSTACK(subdirs); # Cons mit letztem Subdir als CAR retten
  9747.        subdirs = Cdr(subdirs); # alle Subdirs bis aufs letzte
  9748.        subdirs = nreverse(subdirs); # wieder in die richtige Reihenfolge bringen
  9749.        pathname = STACK_1;
  9750.        ThePathname(pathname)->pathname_directory = subdirs; # und in den Pathname setzen
  9751.        # Dieses Directory mu▀ existieren:
  9752.        pushSTACK(pathname);
  9753.        # Stackaufbau: pathname, subdircons, pathname.
  9754.        {var reg3 object dir_namestring = assure_dir_exists(FALSE);
  9755.         # Baue ASCIZ-String des Subdir fⁿr OS:
  9756.         STACK_0 = dir_namestring; # bisheriger Directory-Namestring als 1. String
  9757.         {var reg4 uintC stringcount =
  9758.            subdir_namestring_parts(STACK_1); # und Strings zum letzten Subdir
  9759.          # und kein '\' am Schlu▀ (fⁿr DOS)
  9760.          # und kein '/' am Schlu▀ (fⁿrs OS)
  9761.          pushSTACK(O(null_string)); # und Nullbyte als letzten String
  9762.          {var reg5 object dirstring = string_concat(1+stringcount+1); # zusammenhΣngen
  9763.           skipSTACK(2);
  9764.           return dirstring;
  9765.     } }}}}
  9766.  
  9767. LISPFUNN(make_dir,1)
  9768. # (MAKE-DIR pathname) legt ein neues Unterdirectory pathname an.
  9769.   { var reg1 object pathstring = shorter_directory_arg();
  9770.     #ifdef ATARI
  9771.     var reg2 sintW errorcode =
  9772.       GEMDOS_mkdir(TheAsciz(pathstring)); # Unterdirectory erzeugen
  9773.     if (errorcode < 0) { OS_error(errorcode); } # Error melden
  9774.     #endif
  9775.     #ifdef AMIGAOS
  9776.     set_break_sem_4();
  9777.     begin_system_call();
  9778.     {var reg2 BPTR lock = CreateDir(TheAsciz(pathstring)); # Unterdirectory erzeugen
  9779.      if (lock==BPTR_NULL) { OS_error(); }
  9780.      UnLock(lock); # Lock freigeben
  9781.     }
  9782.     end_system_call();
  9783.     clr_break_sem_4();
  9784.     #endif
  9785.     #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS)
  9786.     begin_system_call();
  9787.     if (mkdir(TheAsciz(pathstring),0777)) # Unterdirectory erzeugen
  9788.       { OS_error(); }
  9789.     end_system_call();
  9790.     #endif
  9791.     value1 = T; mv_count=1; # 1 Wert T
  9792.   }
  9793.  
  9794. LISPFUNN(delete_dir,1)
  9795. # (DELETE-DIR pathname) entfernt das Unterdirectory pathname.
  9796.   { var reg1 object pathstring = shorter_directory_arg();
  9797.     #ifdef ATARI
  9798.     var reg2 sintW errorcode =
  9799.       GEMDOS_rmdir(TheAsciz(pathstring)); # Unterdirectory l÷schen
  9800.     if (errorcode < 0) { OS_error(errorcode); } # Error melden
  9801.     #endif
  9802.     #ifdef AMIGAOS
  9803.     # Noch Test, ob's auch ein Directory und kein File ist??
  9804.     begin_system_call();
  9805.     if (! DeleteFile(TheAsciz(pathstring)) ) # Unterdirectory l÷schen
  9806.       { OS_error(); }
  9807.     end_system_call();
  9808.     #endif
  9809.     #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM)
  9810.     begin_system_call();
  9811.     if (rmdir(TheAsciz(pathstring))) # Unterdirectory l÷schen
  9812.       { OS_error(); }
  9813.     end_system_call();
  9814.     #endif
  9815.     #ifdef RISCOS
  9816.     begin_system_call();
  9817.     if (unlink(TheAsciz(pathstring))) # Unterdirectory l÷schen
  9818.       { OS_error(); }
  9819.     end_system_call();
  9820.     #endif
  9821.     value1 = T; mv_count=1; # 1 Wert T
  9822.   }
  9823.  
  9824. # UP: Initialisiert das Pathname-System.
  9825. # init_pathnames();
  9826. # kann GC ausl÷sen
  9827.   global void init_pathnames (void);
  9828.   global void init_pathnames()
  9829.     {
  9830.       #ifdef PATHNAME_ATARI
  9831.       # Default-Drive initialisieren:
  9832.       { var reg2 sintW errorcode = GEMDOS_CurrentDisk();
  9833.         if (errorcode<0) { OS_error(errorcode); }
  9834.         # errorcode ist jetzt die Nummer des aktuellen Laufwerks.
  9835.        {var reg1 object string = allocate_string(1); # String der LΣnge 1
  9836.         TheSstring(string)->data[0] = 'A' + errorcode; # mit Laufwerksbuchstaben
  9837.         O(default_drive) = string;
  9838.       }}
  9839.       # Drive-Alist initialisieren:
  9840.       { var reg3 uint16 drivebits = # Bitvektor aller angeschlossenen Laufwerke
  9841.           BIOS_DriveMap();
  9842.         pushSTACK(NIL); # Liste := NIL
  9843.        {var reg4 uintB bitnr = 16;
  9844.         # Bits 15..0 durchlaufen (abwΣrts):
  9845.         do { bitnr--;
  9846.              if (drivebits & bit(15)) # Bit bitnr im Bitvektor drivebits gesetzt ?
  9847.                { var reg2 object string = allocate_string(1); # String der LΣnge 1
  9848.                  TheSstring(string)->data[0] = 'A' + bitnr; # mit Laufwerksbuchstaben
  9849.                  pushSTACK(string);
  9850.                 {var reg1 object new_cons = allocate_cons(); # neues Alisten-Cons
  9851.                  Car(new_cons) = popSTACK(); # new_cons = (drive . NIL)
  9852.                  # auf STACK_0 consen:
  9853.                  pushSTACK(new_cons);
  9854.                  new_cons = allocate_cons();
  9855.                  Car(new_cons) = popSTACK(); Cdr(new_cons) = STACK_0;
  9856.                  STACK_0 = new_cons;
  9857.                }}
  9858.              drivebits <<= 1;
  9859.            }
  9860.            until (bitnr == 0);
  9861.         O(drive_alist) = popSTACK();
  9862.       }}
  9863.       # Aktuellen Pfad (von GEMDOS) zum aktuellen Directory auf der
  9864.       # im Default-Drive befindlichen Diskette erklΣren:
  9865.       { # Buffer fⁿr GEMDOS-Interaktion, vgl. GEMDOS_GetDir:
  9866.         var uintB path_buffer[64+1];
  9867.         var reg3 object pathname;
  9868.         { # aktuelles Directory im aktuellen Drive in path_buffer ablegen:
  9869.          {var reg2 sintW errorcode = GEMDOS_GetDir(&path_buffer[0],0);
  9870.           if (errorcode<0) { OS_error(errorcode); }
  9871.          }# Am Schlu▀ ein '\' anfⁿgen:
  9872.          {var reg1 uintB* pathptr = &path_buffer[0];
  9873.           var reg2 uintL len = 0; # StringlΣnge
  9874.           until (*pathptr == 0) { pathptr++; len++; } # ASCIZ-Stringende suchen
  9875.           *pathptr = '\\'; len++; # ein '\' anfⁿgen
  9876.           # und in einen String umwandeln:
  9877.           pathname = make_string(&path_buffer[0],len);
  9878.         }}
  9879.         pathname = coerce_pathname(pathname); # Pathname draus machen
  9880.         # Pathname enthΣlt jetzt das aktuelle Directory.
  9881.         pathname = use_default_dir(pathname);
  9882.         # Pathname enthΣlt jetzt das aktuelle Laufwerk und von der darin
  9883.         # befindlichen Diskette die Seriennummer und das aktuelle Directory.
  9884.         pushSTACK(pathname);
  9885.         change_default(); # Default-Drive, Default-Directory setzen,
  9886.                           # *DEFAULT-PATHNAME-DEFAULTS* initialisieren
  9887.         skipSTACK(1);
  9888.       }
  9889.       #else
  9890.       #if defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  9891.       { # Default-Drive initialisieren:
  9892.         var uintB drive = default_drive();
  9893.         O(default_drive) = make_string(&drive,1);
  9894.       }
  9895.       #endif
  9896.       # *DEFAULT-PATHNAME-DEFAULTS* initialisieren:
  9897.       recalc_defaults_pathname();
  9898.       #endif
  9899.       #ifdef USER_HOMEDIR
  9900.       #ifdef UNIX
  9901.       # Wir ziehen uns das Home-Directory und die benutzbare Shell aus dem
  9902.       # Environment. Es enthΣlt (fast) immer mindestens folgende Variablen:
  9903.       #   LOGNAME = Username beim ersten Einloggen ("wahre" IdentitΣt des Benutzers)
  9904.       #   USER    = aktueller Username
  9905.       #   HOME    = aktuelles Home-Directory, aus /etc/passwd geholt
  9906.       #   SHELL   = aktuelle Standard-Shell, aus /etc/passwd geholt
  9907.       #   PATH    = Suchpfad bei Programmaufruf
  9908.       #   TERM    = Terminalemulation
  9909.       # Wir holen uns HOME (fⁿr "~" - ▄bersetzung) und SHELL (fⁿr EXECUTE).
  9910.       # Bei "~username" mⁿssen wir das /etc/passwd - File absuchen.
  9911.       { # Im Environment nach Variable HOME suchen:
  9912.         begin_system_call();
  9913.        {var reg1 const char* homedir = getenv("HOME");
  9914.         end_system_call();
  9915.         if (!(homedir==NULL)) # gefunden?
  9916.           { O(user_homedir) = asciz_dir_to_pathname(homedir); } # ja -> eintragen
  9917.           else
  9918.           # nein -> Home-Directory aus dem Passwort-File holen:
  9919.           { # empfohlene Methode (siehe GETLOGIN(3V)): erst
  9920.             # getpwnam(getlogin()), dann getpwuid(getuid()) probieren.
  9921.             var reg2 const char* username;
  9922.             var reg1 struct passwd * userpasswd;
  9923.             begin_system_call();
  9924.             # 1. Versuch: getpwnam(getenv("USER"))
  9925.             username = getenv("USER"); # Username aus dem Environment holen
  9926.             if (!(username==NULL))
  9927.               { errno = 0; userpasswd = getpwnam(username); # passwd-Eintrag dazu
  9928.                 if (!(userpasswd==NULL)) goto userpasswd_ok; # gefunden -> ok
  9929.                 if (!(errno==0)) { OS_error(); } # Error melden
  9930.               }
  9931.             # 2. Versuch: getpwnam(getlogin())
  9932.             errno = 0; username = getlogin(); # Username aus /etc/utmp holen
  9933.             if (username==NULL)
  9934.               { if (!(errno==0)) { OS_error(); } } # Error melden
  9935.               else
  9936.               { errno = 0; userpasswd = getpwnam(username); # passwd-Eintrag dazu
  9937.                 if (!(userpasswd==NULL)) goto userpasswd_ok; # gefunden -> ok
  9938.                 if (!(errno==0)) { OS_error(); } # Error melden
  9939.               }
  9940.             # 3. Versuch: getpwuid(getuid())
  9941.             errno = 0; userpasswd = getpwuid(user_uid);
  9942.             if (!(userpasswd==NULL)) # gefunden?
  9943.               { userpasswd_ok:
  9944.                 end_system_call();
  9945.                 O(user_homedir) = asciz_dir_to_pathname(userpasswd->pw_dir); # ja -> Homedir als Pathname eintragen
  9946.               }
  9947.               else
  9948.               { if (!(errno==0)) { OS_error(); } # Error melden
  9949.                 end_system_call();
  9950.                 # nein -> aktuelles Directory nehmen:
  9951.                 O(user_homedir) = default_directory();
  9952.       }}  }   }
  9953.       #endif
  9954.       #endif
  9955.       #if defined(HAVE_SHELL) && !defined(ATARI) && !defined(AMIGAOS)
  9956.       #ifdef UNIX
  9957.       # Die Kommando-Shell O(command_shell) bleibt unverΣndert, sonst
  9958.       # handelt man sich zu viele PortabilitΣtsprobleme ein.
  9959.       { # Im Environment nach Variable SHELL suchen:
  9960.         begin_system_call();
  9961.        {var reg1 const char* shell = getenv("SHELL");
  9962.         end_system_call();
  9963.         if (!(shell==NULL)) # gefunden?
  9964.           { O(user_shell) = asciz_to_string(shell); } # ja -> eintragen
  9965.           # sonst bleibt O(user_shell) auf dem Defaultwert "/bin/csh".
  9966.       }}
  9967.       #endif
  9968.       #ifdef MSDOS
  9969.       { # Im Environment nach Variable COMSPEC suchen:
  9970.         begin_system_call();
  9971.        {var reg1 const char* shell = getenv("COMSPEC");
  9972.         end_system_call();
  9973.         if (!(shell==NULL)) # gefunden?
  9974.           { O(command_shell) = asciz_to_string(shell); } # ja -> eintragen
  9975.           # sonst bleibt O(command_shell) auf dem Defaultwert "\\COMMAND.COM".
  9976.       }}
  9977.       #endif
  9978.       #endif
  9979.     }
  9980.  
  9981. #if defined(ATARI) || defined(DJUNIX) || defined(WATCOM) || defined(EMUNIX_OLD_8d)
  9982. # UP: Legt Datum/Uhrzeit der Datei mit dem Handle handle im 4-Byte-Buffer ab.
  9983. # get_file_write_datetime(handle);
  9984. # > handle: Handle eines (offenen) Files
  9985. # < file_datetime: Datum und Uhrzeit der Datei
  9986.   local var struct { uintW time; uintW date; } file_datetime; # Buffer fⁿrs Ergebnis
  9987.   local void get_file_write_datetime (uintW handle);
  9988.   #ifdef ATARI
  9989.   local void get_file_write_datetime(handle)
  9990.     var reg1 uintW handle;
  9991.     { # Datum und Uhrzeit der Datei in den Buffer:
  9992.       var reg2 sintW errorcode = GEMDOS_GSDTOF(&file_datetime,handle);
  9993.       if (errorcode<0) { OS_error(errorcode); } # Fehler aufgetreten?
  9994.     }
  9995.   #endif
  9996.   #if defined(DJUNIX) || defined(WATCOM)
  9997.   #include <dos.h>
  9998.   local void get_file_write_datetime(handle)
  9999.     var reg1 uintW handle;
  10000.     {
  10001.      #ifndef GNU
  10002.       var union REGS in;
  10003.       var union REGS out;
  10004.       in.regB.ah = 0x57; in.regB.al = 0; # DOS Function 57H
  10005.       in.regW.bx = handle;
  10006.       intdos(&in,&out);
  10007.       file_datetime.time = out.regW.cx;
  10008.       file_datetime.date = out.regW.dx;
  10009.      #else # dasselbe, nur effizienter
  10010.       var uintW time;
  10011.       var uintW date;
  10012.       __asm__ (# DOS Function 57H
  10013.                " movw $0x5700,%%ax ; int $0x21 "
  10014.                : "=c" /* %cx */ (time), "=d" /* %dx */ (date)     # OUT
  10015.                :                                                  # IN
  10016.                : "ax","bx","si","di" /* %eax, %ebx, %esi, %edi */ # CLOBBER
  10017.               );
  10018.       file_datetime.time = time;
  10019.       file_datetime.date = date;
  10020.      #endif
  10021.     }
  10022.   #endif
  10023.   #ifdef EMUNIX_OLD_8d
  10024.   extern int __filetime ( /* int handle, int flag, struct _ftd * */ );
  10025.   #define get_file_write_datetime(handle)  __filetime(handle,0,&file_datetime)
  10026.   #endif
  10027. #endif
  10028. #ifdef AMIGAOS
  10029.   local var struct DateStamp file_datetime; # Buffer fⁿr Datum/Uhrzeit einer Datei
  10030. #endif
  10031. #if defined(UNIX) || defined(EMUNIX_NEW_8e) || defined(RISCOS)
  10032.   local var time_t file_datetime; # Buffer fⁿr Datum/Uhrzeit einer Datei
  10033. #endif
  10034.  
  10035. LISPFUNN(file_write_date,1)
  10036. # (FILE-WRITE-DATE file), CLTL S. 424
  10037.   { var reg1 object pathname = popSTACK(); # pathname-Argument
  10038.     if (streamp(pathname))
  10039.       # Stream -> extra behandeln:
  10040.       { # mu▀ File-Stream sein:
  10041.         pathname = as_file_stream(pathname);
  10042.         # Streamtyp File-Stream
  10043.        #if !defined(AMIGAOS)
  10044.         if ((TheStream(pathname)->strmflags & strmflags_open_B)
  10045.             && (!nullp(TheStream(pathname)->strm_file_handle))
  10046.            )
  10047.           # offener File-Stream
  10048.           { # direkt mit dem Handle arbeiten:
  10049.             #if defined(ATARI) || defined(DJUNIX) || defined(WATCOM) || defined(EMUNIX_OLD_8d)
  10050.             begin_system_call();
  10051.             get_file_write_datetime(TheHandle(TheStream(pathname)->strm_file_handle));
  10052.             end_system_call();
  10053.             #endif
  10054.             #if defined(UNIX) || defined(EMUNIX_NEW_8e) || defined(RISCOS)
  10055.             var struct stat status;
  10056.             begin_system_call();
  10057.             if (!( fstat(TheHandle(TheStream(pathname)->strm_file_handle),&status) ==0))
  10058.               { OS_error(); }
  10059.             end_system_call();
  10060.             file_datetime = status.st_mtime;
  10061.             #endif
  10062.           }
  10063.           else
  10064.        #endif
  10065.           # geschlossener File-Stream -> Truename als Pathname verwenden
  10066.           { pathname = TheStream(pathname)->strm_file_truename;
  10067.             goto is_pathname;
  10068.           }
  10069.       }
  10070.       else
  10071.       { pathname = coerce_pathname(pathname); # zu einem Pathname machen
  10072.         is_pathname: # pathname ist jetzt wirklich ein Pathname
  10073.         check_no_wildcards(pathname); # mit Wildcards -> Fehler
  10074.         pathname = use_default_dir(pathname); # Default-Directory einfⁿgen
  10075.         if (namenullp(pathname)) { fehler_noname(pathname); } # Kein Name angegeben -> Fehler
  10076.         # Name angegeben.
  10077.         pushSTACK(pathname);
  10078.        {# Directory mu▀ existieren:
  10079.         var reg3 object namestring = assure_dir_exists(FALSE); # Filename als ASCIZ-String
  10080.         #ifdef ATARI
  10081.         # Datei ÷ffnen:
  10082.         var reg2 sintW errorcode;
  10083.         errorcode = # Datei zu ÷ffnen versuchen, Modus 0 (Read)
  10084.           GEMDOS_open(TheAsciz(namestring),0);
  10085.         if (errorcode < 0) { OS_error(errorcode); } # Error melden
  10086.         # Nun enthΣlt errorcode das Handle des ge÷ffneten Files.
  10087.         get_file_write_datetime(errorcode); # Datum/Uhrzeit holen
  10088.         errorcode = # Datei gleich wieder schlie▀en
  10089.           GEMDOS_close(errorcode);
  10090.         if (errorcode < 0) { OS_error(errorcode); } # Error melden
  10091.         #endif
  10092.         #ifdef MSDOS
  10093.          #if defined(DJUNIX) || defined(WATCOM) || defined(EMUNIX_OLD_8d)
  10094.           # Datei ÷ffnen:
  10095.           begin_system_call();
  10096.           { var reg2 sintW ergebnis = # Datei zu ÷ffnen versuchen
  10097.               open(TheAsciz(namestring),O_RDONLY);
  10098.             if (ergebnis < 0) { OS_error(); } # Error melden
  10099.             # Nun enthΣlt ergebnis das Handle des ge÷ffneten Files.
  10100.             get_file_write_datetime(ergebnis); # Datum/Uhrzeit holen
  10101.             if (CLOSE(ergebnis) < 0) { OS_error(); } # Datei gleich wieder schlie▀en
  10102.           }
  10103.           end_system_call();
  10104.          #else # defined(EMUNIX_NEW_8e)
  10105.           { var struct stat statbuf;
  10106.             begin_system_call();
  10107.             if (stat(TheAsciz(namestring),&statbuf) < 0) { OS_error(); }
  10108.             end_system_call();
  10109.             if (!S_ISREG(statbuf.st_mode)) { fehler_file_not_exists(); } # Datei mu▀ existieren
  10110.             file_datetime = statbuf.st_mtime;
  10111.           }
  10112.          #endif
  10113.         #endif
  10114.         #ifdef AMIGAOS
  10115.         if (!file_exists(_EMA_)) { fehler_file_not_exists(); } # Datei mu▀ existieren
  10116.         file_datetime = filestatus->fib_Date;
  10117.         #endif
  10118.         #if defined(UNIX) || defined(RISCOS)
  10119.         if (!file_exists(_EMA_)) { fehler_file_not_exists(); } # Datei mu▀ existieren
  10120.         file_datetime = filestatus->st_mtime;
  10121.         #endif
  10122.         skipSTACK(1);
  10123.       }}
  10124.     # Datum/Uhrzeit steht nun im Buffer file_datetime.
  10125.     # In Decoded-Time-Format umwandeln:
  10126.     { var decoded_time timepoint;
  10127.       #if defined(ATARI) || defined(DJUNIX) || defined(WATCOM) || defined(EMUNIX_OLD_8d)
  10128.       convert_timedate(file_datetime.time,file_datetime.date,&timepoint);
  10129.       #endif
  10130.       #if defined(UNIX) || defined(EMUNIX_NEW_8e) || defined(AMIGAOS) || defined(RISCOS)
  10131.       convert_time(&file_datetime,&timepoint);
  10132.       #endif
  10133.       pushSTACK(timepoint.Sekunden);
  10134.       pushSTACK(timepoint.Minuten);
  10135.       pushSTACK(timepoint.Stunden);
  10136.       pushSTACK(timepoint.Tag);
  10137.       pushSTACK(timepoint.Monat);
  10138.       pushSTACK(timepoint.Jahr);
  10139.       funcall(S(encode_universal_time),6);
  10140.       # (ENCODE-UNIVERSAL-TIME Sekunden Minuten Stunden Tag Monat Jahr)
  10141.       # als Ergebnis
  10142.   } }
  10143.  
  10144. LISPFUNN(file_author,1)
  10145. # (FILE-AUTHOR file), CLTL S. 424
  10146.   { var reg1 object pathname = popSTACK(); # pathname-Argument
  10147.     if (streamp(pathname))
  10148.       # Stream -> extra behandeln:
  10149.       { # mu▀ File-Stream sein:
  10150.         pathname = as_file_stream(pathname);
  10151.         # Streamtyp File-Stream
  10152.         if (TheStream(pathname)->strmflags & strmflags_open_B)
  10153.           # offener File-Stream -> OK
  10154.           {}
  10155.           else
  10156.           # geschlossener File-Stream -> Truename als Pathname verwenden
  10157.           { pathname = TheStream(pathname)->strm_file_truename;
  10158.             goto is_pathname;
  10159.           }
  10160.       }
  10161.       else
  10162.       { pathname = coerce_pathname(pathname); # zu einem Pathname machen
  10163.         is_pathname: # pathname ist jetzt wirklich ein Pathname
  10164.         # pathname ist jetzt ein Pathname.
  10165.         check_no_wildcards(pathname); # mit Wildcards -> Fehler
  10166.         pathname = use_default_dir(pathname); # Default-Directory einfⁿgen
  10167.         if (namenullp(pathname)) { fehler_noname(pathname); } # Kein Name angegeben -> Fehler
  10168.         # Name angegeben.
  10169.         pushSTACK(pathname);
  10170.        {# Directory mu▀ existieren:
  10171.         var reg3 object namestring = assure_dir_exists(FALSE); # Filename als ASCIZ-String
  10172.         #ifdef ATARI
  10173.         # ▄berprⁿfe, ob die Datei existiert:
  10174.         var reg2 sintW errorcode;
  10175.         errorcode = # Datei zu ÷ffnen versuchen, Modus 0 (Read)
  10176.           GEMDOS_open(TheAsciz(namestring),0);
  10177.         if (errorcode < 0) { OS_error(errorcode); } # Error melden
  10178.         # Nun enthΣlt errorcode das Handle des ge÷ffneten Files.
  10179.         errorcode = # Datei gleich wieder schlie▀en
  10180.           GEMDOS_close(errorcode);
  10181.         if (errorcode < 0) { OS_error(errorcode); } # Error melden
  10182.         #endif
  10183.         #ifdef MSDOS
  10184.          #if 1
  10185.           # Datei ÷ffnen:
  10186.           begin_system_call();
  10187.           { var reg2 sintW ergebnis = # Datei zu ÷ffnen versuchen
  10188.               open(TheAsciz(namestring),O_RDONLY);
  10189.             if (ergebnis < 0) { OS_error(); } # Error melden
  10190.             # Nun enthΣlt ergebnis das Handle des ge÷ffneten Files.
  10191.             if (CLOSE(ergebnis) < 0) { OS_error(); } # Datei gleich wieder schlie▀en
  10192.           }
  10193.           end_system_call();
  10194.          #else
  10195.           { var struct stat statbuf;
  10196.             begin_system_call();
  10197.             if (stat(TheAsciz(namestring),&statbuf) < 0) { OS_error(); }
  10198.             end_system_call();
  10199.             if (!S_ISREG(statbuf.st_mode)) { fehler_file_not_exists(); } # Datei mu▀ existieren
  10200.           }
  10201.          #endif
  10202.         #endif
  10203.         #if defined(UNIX) || defined(AMIGAOS) || defined(RISCOS)
  10204.         if (!file_exists(_EMA_)) { fehler_file_not_exists(); } # Datei mu▀ existieren
  10205.         #endif
  10206.         skipSTACK(1);
  10207.       }}
  10208.     # Datei existiert -> NIL als Wert
  10209.     value1 = NIL; mv_count=1;
  10210.   }
  10211.  
  10212. #ifdef ATARI
  10213.  
  10214. LISPFUN(execute,1,2,norest,nokey,0,NIL)
  10215. # (EXECUTE file [command-tail [space]]) ruft file auf, mit command-tail als
  10216. # Argumentstring. Es werden space Bytes fⁿrs Programm zur Verfⁿgung gestellt.
  10217. # Default fⁿr command-tail ist "".
  10218. # Default fⁿr space ist ein wenig mehr als (file-length file).
  10219.   { # file ⁿberprⁿfen:
  10220.    {var reg1 object pathname = STACK_2;
  10221.     pathname = coerce_pathname(pathname); # zu einem Pathname machen
  10222.     # pathname ist jetzt ein Pathname.
  10223.     check_no_wildcards(pathname); # mit Wildcards -> Fehler
  10224.     pathname = use_default_dir(pathname); # Default-Directory einfⁿgen
  10225.     if (namenullp(pathname)) { fehler_noname(pathname); } # Kein Name angegeben -> Fehler
  10226.     # Name angegeben.
  10227.     pushSTACK(pathname);
  10228.    }# Directory mu▀ existieren:
  10229.     STACK_(2+1) = assure_dir_exists(FALSE); # Filename als ASCIZ-String
  10230.     # Stackaufbau: filename, command-tail, space, pathname.
  10231.     # Command-Tail ⁿberprⁿfen:
  10232.    {var reg1 object command_tail = STACK_(1+1);
  10233.     if (eq(command_tail,unbound))
  10234.       { command_tail = O(leer_string); } # "" als Default
  10235.       else
  10236.       { if (!stringp(command_tail))
  10237.           { pushSTACK(command_tail); # Wert fⁿr Slot DATUM von TYPE-ERROR
  10238.             pushSTACK(S(string)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  10239.             pushSTACK(command_tail);
  10240.             pushSTACK(TheSubr(subr_self)->name);
  10241.             fehler(type_error,
  10242.                    DEUTSCH ? "~: Command-Tail mu▀ ein String sein, nicht ~" :
  10243.                    ENGLISH ? "~: command tail should be a string, not ~" :
  10244.                    FRANCAIS ? "~ : le paramΦtre de commande doit Ωtre une chaεne et non ~" :
  10245.                    ""
  10246.                   );
  10247.           }
  10248.         command_tail = coerce_ss(command_tail); # in Simple-String umwandeln
  10249.       }
  10250.     STACK_(1+1) = command_tail;
  10251.    }# space ⁿberprⁿfen:
  10252.    {var reg5 uintL space; # Fⁿrs aufzurufende Programm ben÷tigter Platz
  10253.     if (!eq(STACK_(0+1),unbound))
  10254.       # space angegeben
  10255.       { skipSTACK(1); # Pathname vergessen
  10256.         if (!mposfixnump(STACK_0))
  10257.           { # STACK_0 = space, Wert fⁿr Slot DATUM von TYPE-ERROR
  10258.             pushSTACK(O(type_posfixnum)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  10259.             pushSTACK(STACK_1);
  10260.             pushSTACK(TheSubr(subr_self)->name);
  10261.             fehler(type_error,
  10262.                    DEUTSCH ? "~: Platz-Angabe mu▀ ein Fixnum >=0 sein, nicht ~" :
  10263.                    ENGLISH ? "~: space need should be a nonnegative fixnum, not ~" :
  10264.                    FRANCAIS ? "~ : Le besoin en place doit Ωtre exprimΘ par un Fixnum positif et non ~" :
  10265.                    ""
  10266.                   );
  10267.           }
  10268.         space = posfixnum_to_L(popSTACK()); # space-Argument verwenden
  10269.       }
  10270.       else
  10271.       # space bestimmt sich aus dem Header des File. STACK_0 = pathname.
  10272.       { # (OPEN pathname :ELEMENT-TYPE 'UNSIGNED-BYTE) ausfⁿhren:
  10273.         pushSTACK(S(Kelement_type)); pushSTACK(S(unsigned_byte));
  10274.         funcall(L(open),3);
  10275.        {var reg4 object stream = value1; # offener Byte-Stream auf pathname
  10276.         # Stackaufbau: filename, command-tail, dummy.
  10277.         # ▄berprⁿfe, ob das File ein ausfⁿhrbares Programm ist:
  10278.         # Erste 14 Bytes lesen (testet auch, ob File-LΣnge >=14):
  10279.         var uintB buffer[14]; # Word-aligned!
  10280.         {var reg1 uintB* buffptr = &buffer[0];
  10281.          var reg3 uintC count;
  10282.          dotimesC(count,14,
  10283.            { var reg2 object b = read_byte(stream); # nΣchstes Byte lesen (l÷st keine GC aus)
  10284.              if (eq(b,eof_value)) { goto bad; } # File zu klein -> war nix
  10285.              *buffptr++ = (uintB)posfixnum_to_L(b); # Byte ablegen
  10286.            });
  10287.         }
  10288.         # File mu▀ mit $601A anfangen:
  10289.         if (!(*(uintW*)(&buffer[0]) == 0x601A))
  10290.           { bad: # File zu kurz oder fΣngt nicht mit $601A an
  10291.             STACK_0 = stream; stream_close(&STACK_0); # File wieder schlie▀en
  10292.             pushSTACK(STACK_2); # Wert fⁿr Slot PATHNAME von FILE-ERROR
  10293.             pushSTACK(STACK_(2+1)); # filename
  10294.             pushSTACK(TheSubr(subr_self)->name);
  10295.             fehler(file_error,
  10296.                    DEUTSCH ? "~: File ~ ist kein ausfⁿhrbares Programm." :
  10297.                    ENGLISH ? "~: file ~ is not an executable program" :
  10298.                    FRANCAIS ? "~ : Le fichier ~ n'est pas exΘcutable." :
  10299.                    ""
  10300.                   );
  10301.           }
  10302.         space = *(uintL*)(&buffer[2]) # LΣnge TEXT-Segment
  10303.                 + *(uintL*)(&buffer[6]) # LΣnge DATA-Segment
  10304.                 + *(uintL*)(&buffer[10]) # LΣnge BSS-Segment
  10305.                 + sizeof(BASEPAGE) # LΣnge Basepage
  10306.                 + 1000 # genehmigte StacklΣnge
  10307.                 ;
  10308.         STACK_0 = stream; stream_close(&STACK_0); # File wieder schlie▀en
  10309.         skipSTACK(1);
  10310.       }}
  10311.     # Stackaufbau: filename (Simple-ASCIZ-String), Command-tail (Simple-String)
  10312.     # Programm aufrufen:
  10313.     {var reg1 sintL ergebnis = execute(floor(space,2)*2);
  10314.      if (ergebnis < 0) { OS_error(ergebnis); } # Error melden
  10315.      # Rⁿckgabewert verwerten: =0 (OK) -> T, >0 (nicht OK) -> NIL :
  10316.      value1 = (ergebnis==0 ? T : NIL); mv_count=1;
  10317.   }}}
  10318.  
  10319. #endif
  10320.  
  10321. #if defined(UNIX) || defined(MSDOS) || defined(RISCOS)
  10322.  
  10323. LISPFUN(execute,1,0,rest,nokey,0,NIL)
  10324. # (EXECUTE file arg1 arg2 ...) ruft ein File mit gegebenen Argumenten auf.
  10325.   {var reg6 object* args_pointer = rest_args_pointer STACKop 1;
  10326.    {var reg1 object* argptr = args_pointer; # Pointer ⁿber die Argumente
  10327.     # File ⁿberprⁿfen:
  10328.     { var reg2 object* file_ = &NEXT(argptr);
  10329.       var reg3 object pathname = *file_;
  10330.       pathname = coerce_pathname(pathname); # zu einem Pathname machen
  10331.       check_no_wildcards(pathname); # mit Wildcards -> Fehler
  10332.       pathname = use_default_dir(pathname); # Default-Directory einfⁿgen
  10333.       if (namenullp(pathname)) { fehler_noname(pathname); } # Kein Name angegeben -> Fehler
  10334.       # Name angegeben.
  10335.       pushSTACK(pathname);
  10336.      {# Directory mu▀ existieren:
  10337.       var reg4 object namestring = assure_dir_exists(FALSE); # Filename als ASCIZ-String
  10338.       # ▄berprⁿfe, ob die Datei existiert:
  10339.       if_file_exists(namestring, ; , { fehler_file_not_exists(); } );
  10340.       *file_ = namestring; # retten
  10341.       skipSTACK(1);
  10342.     }}
  10343.     # restliche Argumente ⁿberprⁿfen:
  10344.     { var reg3 uintC count;
  10345.       dotimesC(count,argcount,
  10346.         { var reg2 object* arg_ = &NEXT(argptr);
  10347.           pushSTACK(*arg_); funcall(L(string),1); # nΣchstes Argument in String umwandeln
  10348.           *arg_ = string_to_asciz(value1); # und ASCIZ-String umwandeln
  10349.         });
  10350.    }}
  10351.    #if defined(WATCOM) && defined(WINDOWS)
  10352.    # Alle Argumente (nun ASCIZ-Strings) zusammenhΣngen, mit Spaces dazwischen:
  10353.    {var reg1 object* argptr = args_pointer; # Pointer ⁿber die Argumente
  10354.     var reg3 uintC count;
  10355.     dotimesC(count,argcount, # alle Argumente au▀er dem letzten durchlaufen
  10356.       { var reg2 object string = NEXT(argptr); # nΣchster Argumentstring
  10357.         TheSstring(string)->data[TheSstring(string)->length - 1] = ' ';
  10358.       });
  10359.    }
  10360.    { var reg2 object command = string_concat(1+argcount);
  10361.      # Programm aufrufen:
  10362.      begin_system_call();
  10363.     {var reg1 int ergebnis = system(TheAsciz(command));
  10364.      end_system_call();
  10365.      # Rⁿckgabewert verwerten: =0 (OK) -> T, >0 (nicht OK) -> NIL :
  10366.      value1 = (ergebnis==0 ? T : NIL); mv_count=1;
  10367.    }}
  10368.    #endif
  10369.    #if defined(DJUNIX) || defined(EMUNIX) || (defined(WATCOM) && !defined(WINDOWS))
  10370.    {# argv-Array aufbauen:
  10371.     var DYNAMIC_ARRAY(reg5,argv,char*,1+(uintL)argcount+1);
  10372.     { var reg1 object* argptr = args_pointer;
  10373.       var reg2 char** argvptr = &argv[0];
  10374.       var reg4 uintC count;
  10375.       dotimespC(count,argcount+1,
  10376.         { var reg3 object arg = NEXT(argptr); # nΣchstes Argument, ASCIZ-String
  10377.           *argvptr++ = TheAsciz(arg); # in argv einfⁿllen
  10378.         });
  10379.       *argvptr = NULL; # und mit Nullpointer abschlie▀en
  10380.     }
  10381.     # Programm aufrufen:
  10382.     begin_system_call();
  10383.     {var reg2 int flags =
  10384.        #ifdef EMUNIX_NEW_9a
  10385.          P_QUOTE  # Argumente korrekt quoten
  10386.        #else
  10387.          0
  10388.        #endif
  10389.        ;
  10390.      var reg1 int ergebnis = spawnv(P_WAIT|flags,argv[0],argv);
  10391.      end_system_call();
  10392.      if (ergebnis < 0) { OS_error(); } # Error melden
  10393.      # Fertig.
  10394.      set_args_end_pointer(args_pointer); # STACK aufrΣumen
  10395.      # Rⁿckgabewert verwerten: =0 (OK) -> T, >0 (nicht OK) -> NIL :
  10396.      value1 = (ergebnis==0 ? T : NIL); mv_count=1;
  10397.     }
  10398.     FREE_DYNAMIC_ARRAY(argv);
  10399.    }
  10400.    #endif
  10401.    #if defined(UNIX) || defined(RISCOS)
  10402.    { # argv-Array im Stack aufbauen und Strings in den Stack kopieren:
  10403.      var reg9 uintL argvdata_length = 0;
  10404.      { var reg1 object* argptr = args_pointer;
  10405.        var reg3 uintC count;
  10406.        dotimespC(count,argcount+1,
  10407.          { var reg2 object arg = NEXT(argptr); # nΣchstes Argument, ASCIZ-String
  10408.            argvdata_length += TheSstring(arg)->length;
  10409.          });
  10410.      }
  10411.     {var DYNAMIC_ARRAY(reg9,argv,char*,1+(uintL)argcount+1);
  10412.      var DYNAMIC_ARRAY(reg9,argvdata,char,argvdata_length);
  10413.      { var reg8 object* argptr = args_pointer;
  10414.        var reg7 char** argvptr = &argv[0];
  10415.        var reg1 char* argvdataptr = &argvdata[0];
  10416.        var reg5 uintC count;
  10417.        dotimespC(count,argcount+1,
  10418.          { var reg4 object arg = NEXT(argptr); # nΣchstes Argument, ASCIZ-String
  10419.            var reg2 char* ptr = TheAsciz(arg);
  10420.            var reg3 uintL len = TheSstring(arg)->length;
  10421.            *argvptr++ = argvdataptr; # in argv einfⁿllen
  10422.            dotimespL(len,len, { *argvdataptr++ = *ptr++; } ); # und kopieren
  10423.          });
  10424.        *argvptr = NULL; # und mit Nullpointer abschlie▀en
  10425.      }
  10426.      # einen neuen Proze▀ starten:
  10427.      { var reg2 int child;
  10428.        begin_system_call();
  10429.        if ((child = vfork()) ==0)
  10430.          # Dieses Programmstⁿck wird vom Child-Proze▀ ausgefⁿhrt:
  10431.          { execv(argv[0],argv); # Programm aufrufen
  10432.            _exit(-1); # sollte dies mi▀lingen, Child-Proze▀ beenden
  10433.          }
  10434.        # Dieses Programmstⁿck wird wieder vom Aufrufer ausgefⁿhrt:
  10435.        if (child==-1)
  10436.          # Etwas ist mi▀lungen, entweder beim vfork oder beim execv.
  10437.          # In beiden FΣllen wurde errno gesetzt.
  10438.          { OS_error(); }
  10439.        # Warten, bis der Child-Proze▀ beendet wird:
  10440.       {var int status = wait2(child);
  10441.        # vgl. WAIT(2V) und #include <sys/wait.h> :
  10442.        #   WIFSTOPPED(status)  ==  ((status & 0xFF) == 0177)
  10443.        #   WEXITSTATUS(status)  == ((status & 0xFF00) >> 8)
  10444.        end_system_call();
  10445.        # Fertig.
  10446.        set_args_end_pointer(args_pointer); # STACK aufrΣumen
  10447.        value1 = (((status & 0xFF) == 0000) # Proze▀ normal beendet (ohne Signal, ohne Core-Dump) ?
  10448.                  ? # ja -> Exit-Status als Wert:
  10449.                    fixnum( (status & 0xFF00) >> 8)
  10450.                  : NIL # nein -> NIL als Wert
  10451.                 );
  10452.        mv_count=1;
  10453.      }}
  10454.      FREE_DYNAMIC_ARRAY(argvdata);
  10455.      FREE_DYNAMIC_ARRAY(argv);
  10456.    }}
  10457.    #endif
  10458.   }
  10459.  
  10460. #endif
  10461.  
  10462. #ifdef AMIGAOS
  10463.  
  10464. LISPFUN(execute,1,0,norest,nokey,0,NIL)
  10465. # (EXECUTE command-string) schickt einen String an das Betriebssystem.
  10466. # Das ist in diesem Fall mit (SHELL command-string) synonym.
  10467.   { C_shell(); } # SHELL aufrufen, selber Stackaufbau
  10468.  
  10469. #endif
  10470.  
  10471. #ifdef HAVE_SHELL
  10472.  
  10473. # (SHELL) ruft eine Shell auf.
  10474. # (SHELL command) ruft eine Shell auf und lΣ▀t sie ein Kommando ausfⁿhren.
  10475.  
  10476. #if defined(ATARI)
  10477.  
  10478. local void (*online_shell)(); # Pointer auf eine online verfⁿgbare Shell, oder NULL
  10479.  
  10480. # UP: Holt den Pointer auf die Online-Shell, falls vorhanden.
  10481.   local void get_online_shell (void);
  10482.   local void get_online_shell()
  10483.     { online_shell = *(void* *)0x04F6; } # nur im Supervisor-Modus aufzurufen!
  10484.  
  10485. # UP: fⁿhrt ein Shell-Kommando aus.
  10486. # > command: Kommando, ein String
  10487. # kann GC ausl÷sen
  10488.   local void do_shell (object command);
  10489.   local void do_shell(command)
  10490.     var reg1 object command; # Kommando, ein String
  10491.     { if (!(online_shell==NULL))
  10492.         # Online-Shell verfⁿgbar
  10493.         { (*online_shell)(TheAsciz(string_to_asciz(command))); }
  10494.         else
  10495.         # Unsere eigene kleine "Shell" aufrufen:
  10496.         { pushSTACK(command); funcall(S(myshell),1); } # (SYS::MYSHELL command)
  10497.     }
  10498.  
  10499. LISPFUN(shell,0,1,norest,nokey,0,NIL)
  10500.   { var reg1 object command = popSTACK();
  10501.     Supervisor_Exec(get_online_shell);
  10502.     if (eq(command,unbound))
  10503.       { # Wir lesen Zeile fⁿr Zeile ein und ⁿbergeben diese der Shell.
  10504.         # (loop
  10505.         #   (write-string "$ ")
  10506.         #   (let ((line (read-line)))
  10507.         #     (cond ((string-equal line "exit") (return))
  10508.         #           ((string-equal line "help") (write-line "Mit EXIT zurⁿck zum Lisp."))
  10509.         #           (t (shell line))
  10510.         # ) ) )
  10511.         loop
  10512.           { pushSTACK(O(shell_prompt)); funcall(L(write_string),1); # Prompt ausgeben
  10513.             funcall(L(read_line),0); # Zeile lesen
  10514.             if (!stringp(value1)) break; # EOF -> fertig
  10515.             if (string_equal(value1,O(shell_exit))) break; # EXIT -> fertig
  10516.             if (string_equal(value1,O(shell_help))) # HELP-Kommando
  10517.               { pushSTACK(OL(shell_helpstring)); funcall(L(write_line),1); }
  10518.             else
  10519.               { do_shell(value1); } # sonstiges Shell-Kommando ausfⁿhren
  10520.           }
  10521.       }
  10522.       else
  10523.       { pushSTACK(command); funcall(L(string),1); # Argument in String umwandeln
  10524.         do_shell(value1);
  10525.       }
  10526.     value1 = T; mv_count=1; # T als Wert
  10527.   }
  10528.  
  10529. #elif defined(AMIGAOS)
  10530.  
  10531. LISPFUN(shell,0,1,norest,nokey,0,NIL)
  10532.   { var reg1 object command = popSTACK();
  10533.     if (eq(command,unbound))
  10534.       # Kommandointerpreter aufrufen:
  10535.       { run_time_stop();
  10536.         begin_system_call();
  10537.        {var reg2 BOOL ergebnis = FALSE;
  10538.         #if 0 # so einfach geht's wohl nicht
  10539.         ergebnis = Execute("",Input_handle,Output_handle);
  10540.         #else
  10541.         var reg3 Handle terminal = Open("*",MODE_READWRITE);
  10542.         if (!(terminal==Handle_NULL))
  10543.           { ergebnis = Execute("",terminal,Handle_NULL);
  10544.             Close(terminal);
  10545.             Write(Output_handle,CRLFstring,1);
  10546.           }
  10547.         #endif
  10548.         end_system_call();
  10549.         run_time_restart();
  10550.         # Rⁿckgabewert verwerten: ausgefⁿhrt -> T, nicht gefunden -> NIL :
  10551.         value1 = (ergebnis ? T : NIL); mv_count=1;
  10552.       }}
  10553.       else
  10554.       # einzelnes Kommando ausfⁿhren:
  10555.       { if (!stringp(command))
  10556.           { pushSTACK(command); # Wert fⁿr Slot DATUM von TYPE-ERROR
  10557.             pushSTACK(S(string)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  10558.             pushSTACK(command);
  10559.             pushSTACK(TheSubr(subr_self)->name);
  10560.             fehler(type_error,
  10561.                    DEUTSCH ? "~: Befehl mu▀ ein String sein, nicht ~." :
  10562.                    ENGLISH ? "~: the command should be a string, not ~" :
  10563.                    FRANCAIS ? "~ : La commande doit Ωtre de type STRING et non ~." :
  10564.                    ""
  10565.                   );
  10566.           }
  10567.         command = string_to_asciz(command); # in Simple-String umwandeln
  10568.         # Kommando ausfⁿhren:
  10569.         run_time_stop();
  10570.         begin_system_call();
  10571.        {var reg2 BOOL ergebnis = Execute(TheAsciz(command),Handle_NULL,Output_handle);
  10572.         end_system_call();
  10573.         run_time_restart();
  10574.         # Rⁿckgabewert verwerten: ausgefⁿhrt -> T, nicht gefunden -> NIL :
  10575.         value1 = (ergebnis ? T : NIL); mv_count=1;
  10576.       }}
  10577.   }
  10578.  
  10579. #else # UNIX || MSDOS || ...
  10580.  
  10581. LISPFUN(shell,0,1,norest,nokey,0,NIL)
  10582.   { var reg1 object command = popSTACK();
  10583.     if (eq(command,unbound))
  10584.       { # (EXECUTE shell) ausfⁿhren:
  10585.         #ifdef UNIX
  10586.         pushSTACK(O(user_shell)); # Shell-Name
  10587.         #else # MSDOS
  10588.         pushSTACK(O(command_shell)); # Shell-Name
  10589.         #endif
  10590.         funcall(L(execute),1);
  10591.       }
  10592.       else
  10593.       #if defined(MSDOS) || defined(RISCOS)
  10594.       # Dem DOS-Kommandointerpreter mu▀ man das Kommando bereits entlang
  10595.       # der Leerstellen in einzelne Teile zerlegt ⁿbergeben. Die Funktion
  10596.       # system() erledigt uns das zum Glⁿck.
  10597.       { command = string_to_asciz(command);
  10598.         begin_system_call();
  10599.         # Programm aufrufen:
  10600.        {var reg1 int ergebnis = system(TheAsciz(command));
  10601.         end_system_call();
  10602.         # Rⁿckgabewert verwerten: =0 (OK) -> T, >0 (nicht OK) -> NIL :
  10603.         value1 = (ergebnis==0 ? T : NIL); mv_count=1;
  10604.       }}
  10605.       #else
  10606.       { # (EXECUTE shell "-c" command) ausfⁿhren:
  10607.         pushSTACK(O(command_shell)); # Shell-Name
  10608.         pushSTACK(O(command_shell_option)); # Shell-Option "-c"
  10609.         #if defined(MSDOS) && defined(EMUNIX)
  10610.         # Unter DOS 2.x, 3.x kann das Optionen-Zeichen ein anderes sein!
  10611.         if ((_osmode == DOS_MODE) && (_osmajor < 4))
  10612.           { var reg2 uintB swchar = _swchar();
  10613.             if (swchar) # evtl. "/C" durch etwas anderes ersetzen
  10614.               { TheSstring(STACK_0)->data[0] = swchar; } # (destruktiv)
  10615.           }
  10616.         #endif
  10617.         pushSTACK(command);
  10618.         funcall(L(execute),3);
  10619.       }
  10620.       #endif
  10621.   }
  10622.  
  10623. #endif
  10624.  
  10625. #endif
  10626.  
  10627. LISPFUNN(savemem,1)
  10628. # (SAVEMEM pathname) speichert ein Speicherabbild unter pathname ab.
  10629.   { # (OPEN pathname :direction :output) ausfⁿhren:
  10630.     # pathname als 1. Argument
  10631.     pushSTACK(S(Kdirection)); # :DIRECTION als 2. Argument
  10632.     pushSTACK(S(Koutput)); # :OUTPUT als 3. Argument
  10633.     #ifndef UNIX
  10634.     funcall(L(open),3);
  10635.     #else
  10636.     # Unter Unix mit mmap() darf man existierende .mem-Files nicht einfach
  10637.     # ⁿberschreiben, weil laufende Lisp-Prozesse dadurch abstⁿrzen wⁿrden.
  10638.     pushSTACK(S(Kif_exists)); # :IF-EXISTS als 4. Argument
  10639.     pushSTACK(S(Krename_and_delete)); # :RENAME-AND-DELETE als 5. Argument
  10640.     funcall(L(open),5);
  10641.     #endif
  10642.     # Speicherabbild in die Datei schreiben:
  10643.     # (Den Stream mu▀ die Funktion savemem() schlie▀en, auch im Fehlerfalle.)
  10644.     savemem(value1);
  10645.     value1 = T; mv_count=1; # 1 Wert T
  10646.   }
  10647.  
  10648. # ==============================================================================
  10649.  
  10650. #ifdef EMUNIX_PORTABEL
  10651.  
  10652. # Umgehen eines lΣstigen ENAMETOOLONG Errors bei Benutzung von langen
  10653. # Filenamen auf FAT-Drives unter OS/2:
  10654.  
  10655. #undef chdir
  10656. #undef access
  10657. #undef stat
  10658. #undef unlink
  10659. #undef rename
  10660. #undef __findfirst
  10661. #undef mkdir
  10662. #undef open
  10663. #undef creat
  10664. #undef spawnv
  10665.  
  10666. # path2 := verkⁿrzte Kopie von path1
  10667. local void shorten_path (const char* path1, char* path2)
  10668.   { var reg1 const uintB* p1 = path1;
  10669.     var reg2 uintB* p2 = path2;
  10670.     var reg3 uintB c;
  10671.     var reg4 uintC wordlength = 0; # bisherige LΣnge in Name oder Typ
  10672.     var reg5 uintC maxwordlength = 8; # = 8 im Namen, = 3 im Typ
  10673.     loop
  10674.       { c = *p1++;
  10675.         if (c=='\0') { *p2++ = c; break; }
  10676.         if ((c=='\\') || (c=='/') || (c==':'))
  10677.           { *p2++ = c; wordlength = 0; maxwordlength = 8; }
  10678.         elif (c=='.')
  10679.           { *p2++ = c; wordlength = 0; maxwordlength = 3; }
  10680.         else
  10681.           { if (++wordlength <= maxwordlength) { *p2++ = c; } }
  10682.   }   }
  10683.  
  10684. global int my_chdir(path)
  10685.   var reg2 CONST char* path;
  10686.   { var reg1 int erg = chdir(path);
  10687.     if ((erg<0) && (errno==ENAMETOOLONG))
  10688.       { var reg3 char* shorter_path = alloca(asciz_length(path)+1);
  10689.         shorten_path(path,shorter_path);
  10690.         erg = chdir(shorter_path);
  10691.       }
  10692.     return erg;
  10693.   }
  10694.  
  10695. global int my_access(path,amode)
  10696.   var reg3 CONST char* path;
  10697.   var reg2 int amode;
  10698.   { var reg1 int erg = access(path,amode);
  10699.     if ((erg<0) && (errno==ENAMETOOLONG))
  10700.       { var reg4 char* shorter_path = alloca(asciz_length(path)+1);
  10701.         shorten_path(path,shorter_path);
  10702.         erg = access(shorter_path,amode);
  10703.       }
  10704.     return erg;
  10705.   }
  10706.  
  10707. global int my_stat(path,buf)
  10708.   var reg3 CONST char* path;
  10709.   var reg2 struct stat * buf;
  10710.   { var reg1 int erg = stat(path,buf);
  10711.     if ((erg<0) && (errno==ENAMETOOLONG))
  10712.       { var reg4 char* shorter_path = alloca(asciz_length(path)+1);
  10713.         shorten_path(path,shorter_path);
  10714.         erg = stat(shorter_path,buf);
  10715.       }
  10716.     return erg;
  10717.   }
  10718.  
  10719. global int my_unlink(path)
  10720.   var reg2 CONST char* path;
  10721.   { var reg1 int erg = unlink(path);
  10722.     if ((erg<0) && (errno==ENAMETOOLONG))
  10723.       { var reg3 char* shorter_path = alloca(asciz_length(path)+1);
  10724.         shorten_path(path,shorter_path);
  10725.         erg = unlink(shorter_path);
  10726.       }
  10727.     return erg;
  10728.   }
  10729.  
  10730. global int my_rename(oldpath,newpath)
  10731.   var reg3 CONST char* oldpath;
  10732.   var reg2 CONST char* newpath;
  10733.   { var reg1 int erg = rename(oldpath,newpath);
  10734.     if ((erg<0) && (errno==ENAMETOOLONG))
  10735.       { var reg4 char* shorter_oldpath = alloca(asciz_length(oldpath)+1);
  10736.         shorten_path(oldpath,shorter_oldpath);
  10737.         erg = rename(shorter_oldpath,newpath);
  10738.         if ((erg<0) && (errno==ENAMETOOLONG))
  10739.           { var reg5 char* shorter_newpath = alloca(asciz_length(newpath)+1);
  10740.             shorten_path(newpath,shorter_newpath);
  10741.             erg = rename(shorter_oldpath,shorter_newpath);
  10742.       }   }
  10743.     return erg;
  10744.   }
  10745.  
  10746. global int my___findfirst(path,attrib,ffblk)
  10747.   var reg4 const char* path;
  10748.   var reg2 int attrib;
  10749.   var reg3 struct ffblk * ffblk;
  10750.   { var reg1 int erg = __findfirst(path,attrib,ffblk);
  10751.     if ((erg<0) && (errno==ENAMETOOLONG))
  10752.       { var reg5 char* shorter_path = alloca(asciz_length(path)+1);
  10753.         shorten_path(path,shorter_path);
  10754.         erg = __findfirst(shorter_path,attrib,ffblk);
  10755.       }
  10756.     return erg;
  10757.   }
  10758.  
  10759. #ifdef EMUNIX_OLD_8e
  10760.   #define mkdir(path,attrib) (mkdir)(path)
  10761. #endif
  10762. global int my_mkdir(path,attrib)
  10763.   var reg2 CONST char* path;
  10764.   var reg3 long attrib;
  10765.   { var reg1 int erg = mkdir(path,attrib);
  10766.     if ((erg<0) && (errno==ENAMETOOLONG))
  10767.       { var reg4 char* shorter_path = alloca(asciz_length(path)+1);
  10768.         shorten_path(path,shorter_path);
  10769.         erg = mkdir(shorter_path,attrib);
  10770.       }
  10771.     return erg;
  10772.   }
  10773.  
  10774. global int my_open(path,flags)
  10775.   var reg3 CONST char* path;
  10776.   var reg2 int flags;
  10777.   { var reg1 int erg = open(path,flags);
  10778.     if ((erg<0) && (errno==ENAMETOOLONG))
  10779.       { var reg4 char* shorter_path = alloca(asciz_length(path)+1);
  10780.         shorten_path(path,shorter_path);
  10781.         erg = open(shorter_path,flags);
  10782.       }
  10783.     return erg;
  10784.   }
  10785.  
  10786. #define creat(path,mode)  open(path,O_RDWR|O_TRUNC|O_CREAT,mode)
  10787. global int my_creat(path,pmode)
  10788.   var reg3 CONST char* path;
  10789.   var reg2 int pmode;
  10790.   { var reg1 int erg = creat(path,pmode);
  10791.     if ((erg<0) && (errno==ENAMETOOLONG))
  10792.       { var reg4 char* shorter_path = alloca(asciz_length(path)+1);
  10793.         shorten_path(path,shorter_path);
  10794.         erg = creat(shorter_path,pmode);
  10795.       }
  10796.     return erg;
  10797.   }
  10798.  
  10799. global int my_spawnv(pmode,path,argv)
  10800.   var reg2 int pmode;
  10801.   var reg4 CONST char* path;
  10802.   var reg3 CONST char* CONST * argv;
  10803.   { var reg1 int erg = spawnv(pmode,path,argv);
  10804.     if ((erg<0) && (errno==ENAMETOOLONG))
  10805.       { var reg5 char* shorter_path = alloca(asciz_length(path)+1);
  10806.         shorten_path(path,shorter_path);
  10807.         erg = spawnv(pmode,shorter_path,argv);
  10808.       }
  10809.     return erg;
  10810.   }
  10811.  
  10812. #endif
  10813.  
  10814. # ==============================================================================
  10815.  
  10816.