home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-1.LHA / CLISP960530-sr.lha / src / charstrg.d < prev    next >
Encoding:
Text File  |  1996-04-15  |  106.7 KB  |  2,411 lines
  1. # Funktionen für Characters und Strings für CLISP
  2. # Bruno Haible 17.11.1994
  3.  
  4. #include "lispbibl.c"
  5.  
  6. # Character-Umwandlungstabellen:
  7. #if defined(ISOLATIN_CHS)
  8.  # Darin sind eingetragen die bijektiven Klein<-->Groß-Umwandlungen
  9.  #  Klein 61 ... 7A E0 ... F6 F8 ... FE
  10.  #  Groß  41 ... 5A C0 ... D6 D8 ... DE
  11.  #  Beide aA ... zZ àÀ ... öÖ øØ ... th
  12. #elif defined(HPROMAN8_CHS)
  13.  # Darin sind eingetragen die bijektiven Klein<-->Groß-Umwandlungen
  14.  #  Klein 61 ... 7A C4 C5 D5 C6 C7 B2 C0 C1 D1 C2 C3 C8 C9 D9 CA CB
  15.  #  Groß  41 ... 5A E0 DC E5 E7 ED B1 A2 A4 A6 DF AE A1 A3 E6 E8 AD
  16.  #  Was   aA ... zZ a´ e´ i´ o´ u´ y´ a^ e^ i^ o^ u^ a` e` i` o` u`
  17.  #  Klein CC CD DD CE CF EF E2 B7 EA D4 D7 D6 B5 EC E4 F1
  18.  #  Groß  D8 A5 A7 DA DB EE E1 B6 E9 D0 D3 D2 B4 EB E3 F0
  19.  #  Was   äÄ ë  ï  öÖ üÜ y" ãàñÑ õÕ åÅ ae øØ çÇ sv -D th
  20. #elif defined(NEXTSTEP_CHS)
  21.  # Darin sind eingetragen die bijektiven Klein<-->Groß-Umwandlungen
  22.  #  Klein 61 ... 7A D5 ... E0 E2 E4 ... E7 EC ... F0 F1 F2 .. F4 F6 F7 F9 FA FC
  23.  #  Groß  41 ... 5A 81 ... 8C 8D 8E ... 91 92 ... 96 E1 97 .. 99 9A 9B E9 EA 9C
  24.  #  Was   aA ... zZ
  25. #elif defined(IBMPC_CHS)
  26.  # Darin sind eingetragen die bijektiven Klein<-->Groß-Umwandlungen
  27.  #  Klein 61 ... 7A 87 81 82 84 86 91 94 A4
  28.  #  Groß  41 ... 5A 80 9A 90 8E 8F 92 99 A5
  29.  #  Beide aA ... zZ çÇ üÜ éÉ äÄ åÅ æÆ öÖ ñÑ
  30. #else # defined(ASCII_CHS)
  31.  # Darin sind eingetragen die bijektiven Klein<-->Groß-Umwandlungen
  32.  #  Klein 61 ... 7A
  33.  #  Groß  41 ... 5A
  34.  #  Beide aA ... zZ
  35. #endif
  36.  
  37. # Wandelt Byte ch in einen Großbuchstaben
  38. # up_case(ch)
  39.   global uintB up_case (uintB ch);
  40.   global uintB up_case(ch)
  41.     var reg1 uintB ch;
  42.     { # Tabelle für Umwandlung in Großbuchstaben:
  43.       local uintB up_case_table[char_code_limit] =
  44.         #if defined(ISOLATIN_CHS)
  45.           { 0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0A,0x0B,0x0C,0x0D,0x0E,0x0F,
  46.             0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18,0x19,0x1A,0x1B,0x1C,0x1D,0x1E,0x1F,
  47.             0x20,0x21,0x22,0x23,0x24,0x25,0x26,0x27,0x28,0x29,0x2A,0x2B,0x2C,0x2D,0x2E,0x2F,
  48.             0x30,0x31,0x32,0x33,0x34,0x35,0x36,0x37,0x38,0x39,0x3A,0x3B,0x3C,0x3D,0x3E,0x3F,
  49.             0x40,0x41,0x42,0x43,0x44,0x45,0x46,0x47,0x48,0x49,0x4A,0x4B,0x4C,0x4D,0x4E,0x4F,
  50.             0x50,0x51,0x52,0x53,0x54,0x55,0x56,0x57,0x58,0x59,0x5A,0x5B,0x5C,0x5D,0x5E,0x5F,
  51.             0x60,0x41,0x42,0x43,0x44,0x45,0x46,0x47,0x48,0x49,0x4A,0x4B,0x4C,0x4D,0x4E,0x4F,
  52.             0x50,0x51,0x52,0x53,0x54,0x55,0x56,0x57,0x58,0x59,0x5A,0x7B,0x7C,0x7D,0x7E,0x7F,
  53.             0x80,0x81,0x82,0x83,0x84,0x85,0x86,0x87,0x88,0x89,0x8A,0x8B,0x8C,0x8D,0x8E,0x8F,
  54.             0x90,0x91,0x92,0x93,0x94,0x95,0x96,0x97,0x98,0x99,0x9A,0x9B,0x9C,0x9D,0x9E,0x9F,
  55.             0xA0,0xA1,0xA2,0xA3,0xA4,0xA5,0xA6,0xA7,0xA8,0xA9,0xAA,0xAB,0xAC,0xAD,0xAE,0xAF,
  56.             0xB0,0xB1,0xB2,0xB3,0xB4,0xB5,0xB6,0xB7,0xB8,0xB9,0xBA,0xBB,0xBC,0xBD,0xBE,0xBF,
  57.             0xC0,0xC1,0xC2,0xC3,0xC4,0xC5,0xC6,0xC7,0xC8,0xC9,0xCA,0xCB,0xCC,0xCD,0xCE,0xCF,
  58.             0xD0,0xD1,0xD2,0xD3,0xD4,0xD5,0xD6,0xD7,0xD8,0xD9,0xDA,0xDB,0xDC,0xDD,0xDE,0xDF,
  59.             0xC0,0xC1,0xC2,0xC3,0xC4,0xC5,0xC6,0xC7,0xC8,0xC9,0xCA,0xCB,0xCC,0xCD,0xCE,0xCF,
  60.             0xD0,0xD1,0xD2,0xD3,0xD4,0xD5,0xD6,0xF7,0xD8,0xD9,0xDA,0xDB,0xDC,0xDD,0xDE,0xFF,
  61.           };
  62.         #elif defined(HPROMAN8_CHS)
  63.           { 0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0A,0x0B,0x0C,0x0D,0x0E,0x0F,
  64.             0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18,0x19,0x1A,0x1B,0x1C,0x1D,0x1E,0x1F,
  65.             0x20,0x21,0x22,0x23,0x24,0x25,0x26,0x27,0x28,0x29,0x2A,0x2B,0x2C,0x2D,0x2E,0x2F,
  66.             0x30,0x31,0x32,0x33,0x34,0x35,0x36,0x37,0x38,0x39,0x3A,0x3B,0x3C,0x3D,0x3E,0x3F,
  67.             0x40,0x41,0x42,0x43,0x44,0x45,0x46,0x47,0x48,0x49,0x4A,0x4B,0x4C,0x4D,0x4E,0x4F,
  68.             0x50,0x51,0x52,0x53,0x54,0x55,0x56,0x57,0x58,0x59,0x5A,0x5B,0x5C,0x5D,0x5E,0x5F,
  69.             0x60,0x41,0x42,0x43,0x44,0x45,0x46,0x47,0x48,0x49,0x4A,0x4B,0x4C,0x4D,0x4E,0x4F,
  70.             0x50,0x51,0x52,0x53,0x54,0x55,0x56,0x57,0x58,0x59,0x5A,0x7B,0x7C,0x7D,0x7E,0x7F,
  71.             0x80,0x81,0x82,0x83,0x84,0x85,0x86,0x87,0x88,0x89,0x8A,0x8B,0x8C,0x8D,0x8E,0x8F,
  72.             0x90,0x91,0x92,0x93,0x94,0x95,0x96,0x97,0x98,0x99,0x9A,0x9B,0x9C,0x9D,0x9E,0x9F,
  73.             0xA0,0xA1,0xA2,0xA3,0xA4,0xA5,0xA6,0xA7,0xA8,0xA9,0xAA,0xAB,0xAC,0xAD,0xAE,0xAF,
  74.             0xB0,0xB1,0xB2,0xB3,0xB4,0xB4,0xB6,0xB6,0xB8,0xB9,0xBA,0xBB,0xBC,0xBD,0xBE,0xBF,
  75.             0xA2,0xA4,0xDF,0xAE,0xE0,0xDC,0xE7,0xB2,0xA1,0xA3,0xE8,0xAD,0xD8,0xA5,0xDA,0xDB,
  76.             0xD0,0xA6,0xD2,0xD3,0xD0,0xE5,0xD2,0xD3,0xD8,0xE6,0xDA,0xDB,0xDC,0xA7,0xDE,0xDF,
  77.             0xE0,0xE1,0xE1,0xE3,0xE3,0xE5,0xE6,0xE7,0xE8,0xE9,0xE9,0xEB,0xEB,0xED,0xEE,0xEE,
  78.             0xF0,0xF0,0xF2,0xF3,0xF4,0xF5,0xF6,0xF7,0xF8,0xF9,0xFA,0xFB,0xFC,0xFD,0xFE,0xFF,
  79.           };
  80.         #elif defined(NEXTSTEP_CHS)
  81.           { 0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0A,0x0B,0x0C,0x0D,0x0E,0x0F,
  82.             0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18,0x19,0x1A,0x1B,0x1C,0x1D,0x1E,0x1F,
  83.             0x20,0x21,0x22,0x23,0x24,0x25,0x26,0x27,0x28,0x29,0x2A,0x2B,0x2C,0x2D,0x2E,0x2F,
  84.             0x30,0x31,0x32,0x33,0x34,0x35,0x36,0x37,0x38,0x39,0x3A,0x3B,0x3C,0x3D,0x3E,0x3F,
  85.             0x40,0x41,0x42,0x43,0x44,0x45,0x46,0x47,0x48,0x49,0x4A,0x4B,0x4C,0x4D,0x4E,0x4F,
  86.             0x50,0x51,0x52,0x53,0x54,0x55,0x56,0x57,0x58,0x59,0x5A,0x5B,0x5C,0x5D,0x5E,0x5F,
  87.             0x60,0x41,0x42,0x43,0x44,0x45,0x46,0x47,0x48,0x49,0x4A,0x4B,0x4C,0x4D,0x4E,0x4F,
  88.             0x50,0x51,0x52,0x53,0x54,0x55,0x56,0x57,0x58,0x59,0x5A,0x7B,0x7C,0x7D,0x7E,0x7F,
  89.             0x80,0x81,0x82,0x83,0x84,0x85,0x86,0x87,0x88,0x89,0x8A,0x8B,0x8C,0x8D,0x8E,0x8F,
  90.             0x90,0x91,0x92,0x93,0x94,0x95,0x96,0x97,0x98,0x99,0x9A,0x9B,0x9C,0x9D,0x9E,0x9F,
  91.             0xA0,0xA1,0xA2,0xA3,0xA4,0xA5,0xA6,0xA7,0xA8,0xA9,0xAA,0xAB,0xAC,0xAD,0xAE,0xAF,
  92.             0xB0,0xB1,0xB2,0xB3,0xB4,0xB5,0xB6,0xB7,0xB8,0xB9,0xBA,0xBB,0xBC,0xBD,0xBE,0xBF,
  93.             0xC0,0xC1,0xC2,0xC3,0xC4,0xC5,0xC6,0xC7,0xC8,0xC9,0xCA,0xCB,0xCC,0xCD,0xCE,0xCF,
  94.             0xD0,0xD1,0xD2,0xD3,0xD4,0x81,0x82,0x83,0x84,0x85,0x86,0x87,0x88,0x89,0x8A,0x8B,
  95.             0x8C,0xE1,0x8D,0xE3,0x8E,0x8F,0x90,0x91,0xE8,0xE9,0xEA,0xEB,0x92,0x93,0x94,0x95,
  96.             0x96,0xE1,0x97,0x98,0x99,0xF5,0x9A,0x9B,0xF8,0xE9,0xEA,0xFB,0x9C,0xFD,0xFE,0xFF,
  97.           };
  98.         #elif defined(IBMPC_CHS)
  99.           { 0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0A,0x0B,0x0C,0x0D,0x0E,0x0F,
  100.             0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18,0x19,0x1A,0x1B,0x1C,0x1D,0x1E,0x1F,
  101.             0x20,0x21,0x22,0x23,0x24,0x25,0x26,0x27,0x28,0x29,0x2A,0x2B,0x2C,0x2D,0x2E,0x2F,
  102.             0x30,0x31,0x32,0x33,0x34,0x35,0x36,0x37,0x38,0x39,0x3A,0x3B,0x3C,0x3D,0x3E,0x3F,
  103.             0x40,0x41,0x42,0x43,0x44,0x45,0x46,0x47,0x48,0x49,0x4A,0x4B,0x4C,0x4D,0x4E,0x4F,
  104.             0x50,0x51,0x52,0x53,0x54,0x55,0x56,0x57,0x58,0x59,0x5A,0x5B,0x5C,0x5D,0x5E,0x5F,
  105.             0x60,0x41,0x42,0x43,0x44,0x45,0x46,0x47,0x48,0x49,0x4A,0x4B,0x4C,0x4D,0x4E,0x4F,
  106.             0x50,0x51,0x52,0x53,0x54,0x55,0x56,0x57,0x58,0x59,0x5A,0x7B,0x7C,0x7D,0x7E,0x7F,
  107.             0x80,0x9A,0x90,0x83,0x8E,0x85,0x8F,0x80,0x88,0x89,0x8A,0x8B,0x8C,0x8D,0x8E,0x8F,
  108.             0x90,0x92,0x92,0x93,0x99,0x95,0x96,0x97,0x98,0x99,0x9A,0x9B,0x9C,0x9D,0x9E,0x9F,
  109.             0xA0,0xA1,0xA2,0xA3,0xA5,0xA5,0xA6,0xA7,0xA8,0xA9,0xAA,0xAB,0xAC,0xAD,0xAE,0xAF,
  110.             0xB0,0xB1,0xB2,0xB3,0xB4,0xB5,0xB6,0xB7,0xB8,0xB9,0xBA,0xBB,0xBC,0xBD,0xBE,0xBF,
  111.             0xC0,0xC1,0xC2,0xC3,0xC4,0xC5,0xC6,0xC7,0xC8,0xC9,0xCA,0xCB,0xCC,0xCD,0xCE,0xCF,
  112.             0xD0,0xD1,0xD2,0xD3,0xD4,0xD5,0xD6,0xD7,0xD8,0xD9,0xDA,0xDB,0xDC,0xDD,0xDE,0xDF,
  113.             0xE0,0xE1,0xE2,0xE3,0xE4,0xE5,0xE6,0xE7,0xE8,0xE9,0xEA,0xEB,0xEC,0xED,0xEE,0xEF,
  114.             0xF0,0xF1,0xF2,0xF3,0xF4,0xF5,0xF6,0xF7,0xF8,0xF9,0xFA,0xFB,0xFC,0xFD,0xFE,0xFF,
  115.           };
  116.         #else # Standard-Ascii-Umwandlungstabelle: Nur a..z --> A..Z
  117.           { 0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0A,0x0B,0x0C,0x0D,0x0E,0x0F,
  118.             0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18,0x19,0x1A,0x1B,0x1C,0x1D,0x1E,0x1F,
  119.             0x20,0x21,0x22,0x23,0x24,0x25,0x26,0x27,0x28,0x29,0x2A,0x2B,0x2C,0x2D,0x2E,0x2F,
  120.             0x30,0x31,0x32,0x33,0x34,0x35,0x36,0x37,0x38,0x39,0x3A,0x3B,0x3C,0x3D,0x3E,0x3F,
  121.             0x40,0x41,0x42,0x43,0x44,0x45,0x46,0x47,0x48,0x49,0x4A,0x4B,0x4C,0x4D,0x4E,0x4F,
  122.             0x50,0x51,0x52,0x53,0x54,0x55,0x56,0x57,0x58,0x59,0x5A,0x5B,0x5C,0x5D,0x5E,0x5F,
  123.             0x60,0x41,0x42,0x43,0x44,0x45,0x46,0x47,0x48,0x49,0x4A,0x4B,0x4C,0x4D,0x4E,0x4F,
  124.             0x50,0x51,0x52,0x53,0x54,0x55,0x56,0x57,0x58,0x59,0x5A,0x7B,0x7C,0x7D,0x7E,0x7F,
  125.             0x80,0x81,0x82,0x83,0x84,0x85,0x86,0x87,0x88,0x89,0x8A,0x8B,0x8C,0x8D,0x8E,0x8F,
  126.             0x90,0x91,0x92,0x93,0x94,0x95,0x96,0x97,0x98,0x99,0x9A,0x9B,0x9C,0x9D,0x9E,0x9F,
  127.             0xA0,0xA1,0xA2,0xA3,0xA4,0xA5,0xA6,0xA7,0xA8,0xA9,0xAA,0xAB,0xAC,0xAD,0xAE,0xAF,
  128.             0xB0,0xB1,0xB2,0xB3,0xB4,0xB5,0xB6,0xB7,0xB8,0xB9,0xBA,0xBB,0xBC,0xBD,0xBE,0xBF,
  129.             0xC0,0xC1,0xC2,0xC3,0xC4,0xC5,0xC6,0xC7,0xC8,0xC9,0xCA,0xCB,0xCC,0xCD,0xCE,0xCF,
  130.             0xD0,0xD1,0xD2,0xD3,0xD4,0xD5,0xD6,0xD7,0xD8,0xD9,0xDA,0xDB,0xDC,0xDD,0xDE,0xDF,
  131.             0xE0,0xE1,0xE2,0xE3,0xE4,0xE5,0xE6,0xE7,0xE8,0xE9,0xEA,0xEB,0xEC,0xED,0xEE,0xEF,
  132.             0xF0,0xF1,0xF2,0xF3,0xF4,0xF5,0xF6,0xF7,0xF8,0xF9,0xFA,0xFB,0xFC,0xFD,0xFE,0xFF,
  133.           };
  134.         #endif
  135.       return up_case_table[ch];
  136.     }
  137.  
  138. # Wandelt Byte ch in einen Kleinbuchstaben
  139. # down_case(ch)
  140.   global uintB down_case (uintB ch);
  141.   global uintB down_case(ch)
  142.     var reg1 uintB ch;
  143.     { # Tabelle für Umwandlung in Kleinbuchstaben:
  144.       local uintB down_case_table[char_code_limit] =
  145.         #if defined(ISOLATIN_CHS)
  146.           { 0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0A,0x0B,0x0C,0x0D,0x0E,0x0F,
  147.             0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18,0x19,0x1A,0x1B,0x1C,0x1D,0x1E,0x1F,
  148.             0x20,0x21,0x22,0x23,0x24,0x25,0x26,0x27,0x28,0x29,0x2A,0x2B,0x2C,0x2D,0x2E,0x2F,
  149.             0x30,0x31,0x32,0x33,0x34,0x35,0x36,0x37,0x38,0x39,0x3A,0x3B,0x3C,0x3D,0x3E,0x3F,
  150.             0x40,0x61,0x62,0x63,0x64,0x65,0x66,0x67,0x68,0x69,0x6A,0x6B,0x6C,0x6D,0x6E,0x6F,
  151.             0x70,0x71,0x72,0x73,0x74,0x75,0x76,0x77,0x78,0x79,0x7A,0x5B,0x5C,0x5D,0x5E,0x5F,
  152.             0x60,0x61,0x62,0x63,0x64,0x65,0x66,0x67,0x68,0x69,0x6A,0x6B,0x6C,0x6D,0x6E,0x6F,
  153.             0x70,0x71,0x72,0x73,0x74,0x75,0x76,0x77,0x78,0x79,0x7A,0x7B,0x7C,0x7D,0x7E,0x7F,
  154.             0x80,0x81,0x82,0x83,0x84,0x85,0x86,0x87,0x88,0x89,0x8A,0x8B,0x8C,0x8D,0x8E,0x8F,
  155.             0x90,0x91,0x92,0x93,0x94,0x95,0x96,0x97,0x98,0x99,0x9A,0x9B,0x9C,0x9D,0x9E,0x9F,
  156.             0xA0,0xA1,0xA2,0xA3,0xA4,0xA5,0xA6,0xA7,0xA8,0xA9,0xAA,0xAB,0xAC,0xAD,0xAE,0xAF,
  157.             0xB0,0xB1,0xB2,0xB3,0xB4,0xB5,0xB6,0xB7,0xB8,0xB9,0xBA,0xBB,0xBC,0xBD,0xBE,0xBF,
  158.             0xE0,0xE1,0xE2,0xE3,0xE4,0xE5,0xE6,0xE7,0xE8,0xE9,0xEA,0xEB,0xEC,0xED,0xEE,0xEF,
  159.             0xF0,0xF1,0xF2,0xF3,0xF4,0xF5,0xF6,0xD7,0xF8,0xF9,0xFA,0xFB,0xFC,0xFD,0xFE,0xDF,
  160.             0xE0,0xE1,0xE2,0xE3,0xE4,0xE5,0xE6,0xE7,0xE8,0xE9,0xEA,0xEB,0xEC,0xED,0xEE,0xEF,
  161.             0xF0,0xF1,0xF2,0xF3,0xF4,0xF5,0xF6,0xF7,0xF8,0xF9,0xFA,0xFB,0xFC,0xFD,0xFE,0xFF,
  162.           };
  163.         #elif defined(HPROMAN8_CHS)
  164.           { 0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0A,0x0B,0x0C,0x0D,0x0E,0x0F,
  165.             0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18,0x19,0x1A,0x1B,0x1C,0x1D,0x1E,0x1F,
  166.             0x20,0x21,0x22,0x23,0x24,0x25,0x26,0x27,0x28,0x29,0x2A,0x2B,0x2C,0x2D,0x2E,0x2F,
  167.             0x30,0x31,0x32,0x33,0x34,0x35,0x36,0x37,0x38,0x39,0x3A,0x3B,0x3C,0x3D,0x3E,0x3F,
  168.             0x40,0x61,0x62,0x63,0x64,0x65,0x66,0x67,0x68,0x69,0x6A,0x6B,0x6C,0x6D,0x6E,0x6F,
  169.             0x70,0x71,0x72,0x73,0x74,0x75,0x76,0x77,0x78,0x79,0x7A,0x5B,0x5C,0x5D,0x5E,0x5F,
  170.             0x60,0x61,0x62,0x63,0x64,0x65,0x66,0x67,0x68,0x69,0x6A,0x6B,0x6C,0x6D,0x6E,0x6F,
  171.             0x70,0x71,0x72,0x73,0x74,0x75,0x76,0x77,0x78,0x79,0x7A,0x7B,0x7C,0x7D,0x7E,0x7F,
  172.             0x80,0x81,0x82,0x83,0x84,0x85,0x86,0x87,0x88,0x89,0x8A,0x8B,0x8C,0x8D,0x8E,0x8F,
  173.             0x90,0x91,0x92,0x93,0x94,0x95,0x96,0x97,0x98,0x99,0x9A,0x9B,0x9C,0x9D,0x9E,0x9F,
  174.             0xA0,0xC8,0xC0,0xC9,0xC1,0xCD,0xD1,0xDD,0xA8,0xA9,0xAA,0xAB,0xAC,0xCB,0xC3,0xAF,
  175.             0xB0,0xB2,0xB2,0xB3,0xB5,0xB5,0xB7,0xB7,0xB8,0xB9,0xBA,0xBB,0xBC,0xBD,0xBE,0xBF,
  176.             0xC0,0xC1,0xC2,0xC3,0xC4,0xC5,0xC6,0xC7,0xC8,0xC9,0xCA,0xCB,0xCC,0xCD,0xCE,0xCF,
  177.             0xD4,0xD1,0xD6,0xD7,0xD4,0xD5,0xD6,0xD7,0xCC,0xD9,0xCE,0xCF,0xC5,0xDD,0xDE,0xC2,
  178.             0xC4,0xE2,0xE2,0xE4,0xE4,0xD5,0xD9,0xC6,0xCA,0xEA,0xEA,0xEC,0xEC,0xC7,0xEF,0xEF,
  179.             0xF1,0xF1,0xF2,0xF3,0xF4,0xF5,0xF6,0xF7,0xF8,0xF9,0xFA,0xFB,0xFC,0xFD,0xFE,0xFF,
  180.           };
  181.         #elif defined(NEXTSTEP_CHS)
  182.           { 0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0A,0x0B,0x0C,0x0D,0x0E,0x0F,
  183.             0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18,0x19,0x1A,0x1B,0x1C,0x1D,0x1E,0x1F,
  184.             0x20,0x21,0x22,0x23,0x24,0x25,0x26,0x27,0x28,0x29,0x2A,0x2B,0x2C,0x2D,0x2E,0x2F,
  185.             0x30,0x31,0x32,0x33,0x34,0x35,0x36,0x37,0x38,0x39,0x3A,0x3B,0x3C,0x3D,0x3E,0x3F,
  186.             0x40,0x61,0x62,0x63,0x64,0x65,0x66,0x67,0x68,0x69,0x6A,0x6B,0x6C,0x6D,0x6E,0x6F,
  187.             0x70,0x71,0x72,0x73,0x74,0x75,0x76,0x77,0x78,0x79,0x7A,0x5B,0x5C,0x5D,0x5E,0x5F,
  188.             0x60,0x61,0x62,0x63,0x64,0x65,0x66,0x67,0x68,0x69,0x6A,0x6B,0x6C,0x6D,0x6E,0x6F,
  189.             0x70,0x71,0x72,0x73,0x74,0x75,0x76,0x77,0x78,0x79,0x7A,0x7B,0x7C,0x7D,0x7E,0x7F,
  190.             0x80,0xD5,0xD6,0xD7,0xD8,0xD9,0xDA,0xDB,0xDC,0xDD,0xDE,0xDF,0xE0,0xE2,0xE4,0xE5,
  191.             0xE6,0xE7,0xEC,0xED,0xEE,0xEF,0xF0,0xF2,0xF3,0xF4,0xF6,0xF7,0xFC,0x9D,0x9E,0x9F,
  192.             0xA0,0xA1,0xA2,0xA3,0xA4,0xA5,0xA6,0xA7,0xA8,0xA9,0xAA,0xAB,0xAC,0xAD,0xAE,0xAF,
  193.             0xB0,0xB1,0xB2,0xB3,0xB4,0xB5,0xB6,0xB7,0xB8,0xB9,0xBA,0xBB,0xBC,0xBD,0xBE,0xBF,
  194.             0xC0,0xC1,0xC2,0xC3,0xC4,0xC5,0xC6,0xC7,0xC8,0xC9,0xCA,0xCB,0xCC,0xCD,0xCE,0xCF,
  195.             0xD0,0xD1,0xD2,0xD3,0xD4,0xD5,0xD6,0xD7,0xD8,0xD9,0xDA,0xDB,0xDC,0xDD,0xDE,0xDF,
  196.             0xE0,0xF1,0xE2,0xE3,0xE4,0xE5,0xE6,0xE7,0xE8,0xF9,0xFA,0xEB,0xEC,0xED,0xEE,0xEF,
  197.             0xF0,0xF1,0xF2,0xF3,0xF4,0xF5,0xF6,0xF7,0xF8,0xF9,0xFA,0xFB,0xFC,0xFD,0xFE,0xFF,
  198.           };
  199.         #elif defined(IBMPC_CHS)
  200.           { 0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0A,0x0B,0x0C,0x0D,0x0E,0x0F,
  201.             0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18,0x19,0x1A,0x1B,0x1C,0x1D,0x1E,0x1F,
  202.             0x20,0x21,0x22,0x23,0x24,0x25,0x26,0x27,0x28,0x29,0x2A,0x2B,0x2C,0x2D,0x2E,0x2F,
  203.             0x30,0x31,0x32,0x33,0x34,0x35,0x36,0x37,0x38,0x39,0x3A,0x3B,0x3C,0x3D,0x3E,0x3F,
  204.             0x40,0x61,0x62,0x63,0x64,0x65,0x66,0x67,0x68,0x69,0x6A,0x6B,0x6C,0x6D,0x6E,0x6F,
  205.             0x70,0x71,0x72,0x73,0x74,0x75,0x76,0x77,0x78,0x79,0x7A,0x5B,0x5C,0x5D,0x5E,0x5F,
  206.             0x60,0x61,0x62,0x63,0x64,0x65,0x66,0x67,0x68,0x69,0x6A,0x6B,0x6C,0x6D,0x6E,0x6F,
  207.             0x70,0x71,0x72,0x73,0x74,0x75,0x76,0x77,0x78,0x79,0x7A,0x7B,0x7C,0x7D,0x7E,0x7F,
  208.             0x87,0x81,0x82,0x83,0x84,0x85,0x86,0x87,0x88,0x89,0x8A,0x8B,0x8C,0x8D,0x84,0x86,
  209.             0x82,0x91,0x91,0x93,0x94,0x95,0x96,0x97,0x98,0x94,0x81,0x9B,0x9C,0x9D,0x9E,0x9F,
  210.             0xA0,0xA1,0xA2,0xA3,0xA4,0xA4,0xA6,0xA7,0xA8,0xA9,0xAA,0xAB,0xAC,0xAD,0xAE,0xAF,
  211.             0xB0,0xB1,0xB2,0xB3,0xB4,0xB5,0xB6,0xB7,0xB8,0xB9,0xBA,0xBB,0xBC,0xBD,0xBE,0xBF,
  212.             0xC0,0xC1,0xC2,0xC3,0xC4,0xC5,0xC6,0xC7,0xC8,0xC9,0xCA,0xCB,0xCC,0xCD,0xCE,0xCF,
  213.             0xD0,0xD1,0xD2,0xD3,0xD4,0xD5,0xD6,0xD7,0xD8,0xD9,0xDA,0xDB,0xDC,0xDD,0xDE,0xDF,
  214.             0xE0,0xE1,0xE2,0xE3,0xE4,0xE5,0xE6,0xE7,0xE8,0xE9,0xEA,0xEB,0xEC,0xED,0xEE,0xEF,
  215.             0xF0,0xF1,0xF2,0xF3,0xF4,0xF5,0xF6,0xF7,0xF8,0xF9,0xFA,0xFB,0xFC,0xFD,0xFE,0xFF,
  216.           };
  217.         #else # Standard-Ascii-Umwandlungstabelle: Nur A..Z --> a..z
  218.           { 0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0A,0x0B,0x0C,0x0D,0x0E,0x0F,
  219.             0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18,0x19,0x1A,0x1B,0x1C,0x1D,0x1E,0x1F,
  220.             0x20,0x21,0x22,0x23,0x24,0x25,0x26,0x27,0x28,0x29,0x2A,0x2B,0x2C,0x2D,0x2E,0x2F,
  221.             0x30,0x31,0x32,0x33,0x34,0x35,0x36,0x37,0x38,0x39,0x3A,0x3B,0x3C,0x3D,0x3E,0x3F,
  222.             0x40,0x61,0x62,0x63,0x64,0x65,0x66,0x67,0x68,0x69,0x6A,0x6B,0x6C,0x6D,0x6E,0x6F,
  223.             0x70,0x71,0x72,0x73,0x74,0x75,0x76,0x77,0x78,0x79,0x7A,0x5B,0x5C,0x5D,0x5E,0x5F,
  224.             0x60,0x61,0x62,0x63,0x64,0x65,0x66,0x67,0x68,0x69,0x6A,0x6B,0x6C,0x6D,0x6E,0x6F,
  225.             0x70,0x71,0x72,0x73,0x74,0x75,0x76,0x77,0x78,0x79,0x7A,0x7B,0x7C,0x7D,0x7E,0x7F,
  226.             0x80,0x81,0x82,0x83,0x84,0x85,0x86,0x87,0x88,0x89,0x8A,0x8B,0x8C,0x8D,0x8E,0x8F,
  227.             0x90,0x91,0x92,0x93,0x94,0x95,0x96,0x97,0x98,0x99,0x9A,0x9B,0x9C,0x9D,0x9E,0x9F,
  228.             0xA0,0xA1,0xA2,0xA3,0xA4,0xA5,0xA6,0xA7,0xA8,0xA9,0xAA,0xAB,0xAC,0xAD,0xAE,0xAF,
  229.             0xB0,0xB1,0xB2,0xB3,0xB4,0xB5,0xB6,0xB7,0xB8,0xB9,0xBA,0xBB,0xBC,0xBD,0xBE,0xBF,
  230.             0xC0,0xC1,0xC2,0xC3,0xC4,0xC5,0xC6,0xC7,0xC8,0xC9,0xCA,0xCB,0xCC,0xCD,0xCE,0xCF,
  231.             0xD0,0xD1,0xD2,0xD3,0xD4,0xD5,0xD6,0xD7,0xD8,0xD9,0xDA,0xDB,0xDC,0xDD,0xDE,0xDF,
  232.             0xE0,0xE1,0xE2,0xE3,0xE4,0xE5,0xE6,0xE7,0xE8,0xE9,0xEA,0xEB,0xEC,0xED,0xEE,0xEF,
  233.             0xF0,0xF1,0xF2,0xF3,0xF4,0xF5,0xF6,0xF7,0xF8,0xF9,0xFA,0xFB,0xFC,0xFD,0xFE,0xFF,
  234.           };
  235.         #endif
  236.       return down_case_table[ch];
  237.     }
  238.  
  239. # UP: Stellt fest, ob ein Character alphabetisch ist.
  240. # alphap(ch)
  241. # > ch: Character-Code
  242. # < ergebnis: TRUE falls alphabetisch, FALSE sonst.
  243. # Alphabetische Characters sind die mit einem Code c, mit
  244. # $41 <= c <= $5A oder $61 <= c <= $7A
  245. #if defined(ISOLATIN_CHS)
  246. # oder $C0 <= c außer c=$D7,$F7.
  247. #elif defined(HPROMAN8_CHS)
  248. # oder $A1 <= c <= $A7 oder $AD <= c <= $AE oder $B1 <= c <= $B7 außer c=$B3
  249. # oder $C0 <= c <= $F1.
  250. #elif defined(NEXTSTEP_CHS)
  251. # oder $81 <= c <= $9D oder $D5 <= c <= $FD.
  252. #elif defined(IBMPC_CHS)
  253. # oder $80 <= c <= $9A oder $9F <= c <= $A7.
  254. #endif
  255. # Darin sind (siehe CLTL S. 236 oben) aller Uppercase- und alle Lowercase-
  256. # Characters enthalten.
  257.   local boolean alphap (uintB ch);
  258.   local boolean alphap(ch)
  259.     var reg1 uintB ch;
  260.     { if (ch < 0x41) goto no; if (ch <= 0x5A) goto yes;
  261.       if (ch < 0x61) goto no; if (ch <= 0x7A) goto yes;
  262.       #if defined(ISOLATIN_CHS)
  263.       if (ch < 0xC0) goto no;
  264.       if ((ch == 0xD7) || (ch == 0xF7)) goto no; else goto yes;
  265.       #elif defined(HPROMAN8_CHS)
  266.       if (ch < 0xA1) goto no;
  267.       if (ch > 0xF1) goto no; if (ch >= 0xC0) goto yes;
  268.       if (ch <= 0xA7) goto yes;
  269.       if (ch < 0xB1)
  270.         { if (ch < 0xAD) goto no; if (ch <= 0xAE) goto yes; goto no; }
  271.         else
  272.         { if (ch > 0xB7) goto no; if (ch == 0xB3) goto no; else goto yes; }
  273.       #elif defined(NEXTSTEP_CHS)
  274.       if (ch < 0x81) goto no; if (ch <= 0x9D) goto yes;
  275.       if (ch < 0xD5) goto no; if (ch <= 0xFD) goto yes;
  276.       #elif defined(IBMPC_CHS)
  277.       if (ch < 0x80) goto no; if (ch <= 0x9A) goto yes;
  278.       if (ch < 0x9F) goto no; if (ch <= 0xA7) goto yes;
  279.       #endif
  280.       no: return FALSE;
  281.       yes: return TRUE;
  282.     }
  283.  
  284. # Stellt fest, ob ein Character alphanumerisch ist.
  285. # alphanumericp(ch)
  286. # > ch: Character-Code
  287. # < ergebnis: TRUE falls alphanumerisch, FALSE sonst.
  288. # Alphanumerische Characters sind die alphabetischen und die Ziffern.
  289.   global boolean alphanumericp (uintB ch);
  290.   global boolean alphanumericp(ch)
  291.     var reg2 uintB ch;
  292.     { if (('0' <= ch) && (ch <= '9'))
  293.         return TRUE; # '0' <= ch <= '9' ist alphanumerisch
  294.         else
  295.         return alphap(ch);
  296.     }
  297.  
  298. # Stellt fest, ob ein Character ein Graphic-Character ("druckend") ist.
  299. # graphic_char_p(ch)
  300. # > ch: Character-Code
  301. # < ergebnis: TRUE falls druckend, FALSE sonst.
  302. # Graphic-Characters sind die mit einem Code c, mit
  303. #if defined(ISOLATIN_CHS) || defined(HPROMAN8_CHS)
  304. #       $20 <= c <= $7E oder $A0 <= c < $100.
  305. #elif defined(NEXTSTEP_CHS)
  306. #       $20 <= c <= $7E oder $80 <= c <= $A5 oder c in {$A7,$A8,$AA,$AB,$AE..$B7}
  307. #       oder $BA <= c <= $FD außer c = $CD.
  308. #elif defined(IBMPC_CHS)
  309. #       $20 <= c < $100 oder c in {1,..,6}u{14,..,25}u{28,..,31}.
  310. #       [c=11 und c=12 werden zwar auch druckend ausgegeben, aber c=12
  311. #        ist unser #\Page, und c=11 streichen wir aus Gleichberechtigungs-
  312. #        gründen.]
  313. #else # defined(ASCII_CHS)
  314. #       $20 <= c <= $7E.
  315. #endif
  316.   global boolean graphic_char_p (uintB ch);
  317.   global boolean graphic_char_p(ch)
  318.     var reg1 uintB ch;
  319.     {
  320.       #if defined(ISOLATIN_CHS) || defined(HPROMAN8_CHS)
  321.       if ((('~' >= ch) && (ch >= ' ')) || (ch >= 0xA0)) goto yes; else goto no;
  322.       #elif defined(NEXTSTEP_CHS)
  323.       if (ch <= '~') { if (ch >= ' ') goto yes; else goto no; }
  324.       if (ch < 0xC0)
  325.         { if (ch < 0xA0) { if (ch >= 0x80) goto yes; else goto no; }
  326.           # Bit ch-0xA0 aus der 32-Bit-Zahl %11111100111111111100110110111111 holen:
  327.           if (0xFCFFCDBF & bit(ch-0xA0)) goto yes; else goto no;
  328.         }
  329.         else
  330.         { if ((ch <= 0xFD) && !(ch == 0xCD)) goto yes; else goto no; }
  331.       #elif defined(IBMPC_CHS)
  332.       if (ch >= ' ') goto yes; # >= ' ' -> ja
  333.       # 0 <= ch < 32.
  334.       # Bit ch aus der 32-Bit-Zahl %11110011111111111100000001111110 holen:
  335.       if (0xF3FFC07EUL & bit(ch)) goto yes; else goto no;
  336.       #else # defined(ASCII_CHS)
  337.       if (ch >= ' ') goto yes; else goto no;
  338.       #endif
  339.       no: return FALSE;
  340.       yes: return TRUE;
  341.     }
  342.  
  343. # UP: verfolgt einen String.
  344. # unpack_string(string,&len)
  345. # > object string: ein String.
  346. # < uintL len: Anzahl der Zeichen des Strings.
  347. # < uintB* ergebnis: Anfangsadresse der Bytes
  348.   global uintB* unpack_string (object string, uintL* len);
  349.   global uintB* unpack_string(string,len)
  350.     var reg1 object string;
  351.     var reg2 uintL* len;
  352.     { if (simple_string_p(string))
  353.         { *len = TheSstring(string)->length;
  354.           return &TheSstring(string)->data[0];
  355.         }
  356.         else
  357.         # String, aber kein Simple-String => Displacement verfolgen
  358.         { # Länge bestimmen (wie in vector_length in ARRAY.D):
  359.           var reg3 uintL size;
  360.           { var reg2 Array addr = TheArray(string);
  361.             var reg3 uintL offset = offsetofa(array_,dims);
  362.             if (addr->flags & bit(arrayflags_dispoffset_bit))
  363.               offset += sizeof(uintL);
  364.             # Bei addr+offset fangen die Dimensionen an.
  365.             if (addr->flags & bit(arrayflags_fillp_bit)) # evtl. Fillpointer
  366.               offset += sizeof(uintL);
  367.             size = *(uintL*)pointerplus(addr,offset);
  368.           }
  369.           *len = size;
  370.           # Displacement verfolgen:
  371.           { var uintL index = 0;
  372.             var reg3 object datenvektor = array1_displace_check(string,size,&index);
  373.             return &TheSstring(datenvektor)->data[index];
  374.         } }
  375.     }
  376.  
  377. # UP: vergleicht zwei Strings auf Gleichheit
  378. # string_gleich(string1,string2)
  379. # > string1: String
  380. # > string2: simple-string
  381. # < ergebnis: /=0, wenn gleich
  382.   global boolean string_gleich (object string1, object string2);
  383.   global boolean string_gleich(string1,string2)
  384.     var reg4 object string1;
  385.     var reg5 object string2;
  386.     { var uintL len1;
  387.       var reg1 uintB* ptr1;
  388.       var reg2 uintB* ptr2;
  389.       ptr1 = unpack_string(string1,&len1);
  390.       # Ab ptr1 kommen genau len1 Zeichen.
  391.       # Längenvergleich:
  392.       if (!(len1 == TheSstring(string2)->length)) goto no;
  393.       ptr2 = &TheSstring(string2)->data[0];
  394.       # Ab ptr2 kommen genau (ebenfalls) len1 Zeichen.
  395.       # Die len1 Zeichen vergleichen:
  396.       { var reg3 uintL count;
  397.         dotimesL(count,len1, { if (!(*ptr1++ == *ptr2++)) goto no; } );
  398.       }
  399.       return TRUE;
  400.       no: return FALSE;
  401.     }
  402.  
  403. # UP: vergleicht zwei Strings auf Gleichheit, case-insensitive
  404. # string_equal(string1,string2)
  405. # > string1: String
  406. # > string2: simple-string
  407. # < ergebnis: /=0, wenn gleich
  408.   global boolean string_equal (object string1, object string2);
  409.   global boolean string_equal(string1,string2)
  410.     var reg4 object string1;
  411.     var reg5 object string2;
  412.     { var uintL len1;
  413.       var reg1 uintB* ptr1;
  414.       var reg2 uintB* ptr2;
  415.       ptr1 = unpack_string(string1,&len1);
  416.       # Ab ptr1 kommen genau len1 Zeichen.
  417.       # Längenvergleich:
  418.       if (!(len1 == TheSstring(string2)->length)) goto no;
  419.       ptr2 = &TheSstring(string2)->data[0];
  420.       # Ab ptr2 kommen genau (ebenfalls) len1 Zeichen.
  421.       # Die len1 Zeichen vergleichen:
  422.       { var reg3 uintL count;
  423.         dotimesL(count,len1, { if (!(up_case(*ptr1++) == up_case(*ptr2++))) goto no; } );
  424.       }
  425.       return TRUE;
  426.       no: return FALSE;
  427.     }
  428.  
  429. # UP: kopiert einen String und macht dabei einen Simple-String draus.
  430. # copy_string(string)
  431. # > string: String
  432. # < ergebnis: Simple-String mit denselben Zeichen
  433. # kann GC auslösen
  434.   global object copy_string (object string);
  435.   global object copy_string(string)
  436.     var reg5 object string;
  437.     { pushSTACK(string); # String retten
  438.      {var reg3 uintL len = vector_length(string); # Länge berechnen
  439.       var reg4 object new_string = allocate_string(len);
  440.       # new_string = neuer Simple-String mit vorgegebener Länge len
  441.       string = popSTACK(); # String zurück
  442.       if (!(len==0))
  443.         { var local uintL len_; # nochmals die Länge, unbenutzt
  444.           var reg1 uintB* ptr1 = unpack_string(string,&len_);
  445.           var reg2 uintB* ptr2 = &TheSstring(new_string)->data[0];
  446.           # Kopierschleife: Kopiere len Bytes von ptr1[] nach ptr2[]:
  447.           dotimespL(len,len, { *ptr2++ = *ptr1++; } );
  448.         }
  449.       return new_string;
  450.     }}
  451.  
  452. # UP: wandelt einen String in einen Simple-String um.
  453. # coerce_ss(obj)
  454. # > obj: Lisp-Objekt, sollte ein String sein.
  455. # < ergebnis: Simple-String mit denselben Zeichen
  456. # kann GC auslösen
  457.   global object coerce_ss (object obj);
  458.   global object coerce_ss(obj)
  459.     var reg1 object obj;
  460.     { switch (typecode(obj))
  461.         { case_sstring:
  462.             # Simple-String, unverändert zurück
  463.             return obj;
  464.           case_ostring:
  465.             # sonstiger String, kopieren
  466.             return copy_string(obj);
  467.           default:
  468.             pushSTACK(obj); # Wert für Slot DATUM von TYPE-ERROR
  469.             pushSTACK(S(string)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  470.             pushSTACK(obj);
  471.             //: DEUTSCH "Das ist kein String: ~"
  472.             //: ENGLISH "This is not a string: ~"
  473.             //: FRANCAIS "Ceci n'est pas une chaîne : ~"
  474.             fehler(type_error,GETTEXT("This is not a string: ~"));
  475.     }   }
  476.  
  477. # UP: Konversion eines Objekts zu einem Character
  478. # coerce_char(obj)
  479. # > obj: Lisp-Objekt
  480. # < ergebnis: Character oder NIL
  481.   global object coerce_char (object obj);
  482.   global object coerce_char(obj)
  483.     var reg1 object obj;
  484.     { if (charp(obj))
  485.         return obj; # Character unverändert zurück
  486.         else
  487.         if (symbolp(obj))
  488.           { # obj ist ein Symbol
  489.             obj = TheSymbol(obj)->pname; goto string;
  490.           }
  491.           else
  492.           if (stringp(obj))
  493.             { string: # obj ist ein String
  494.               { var uintL len;
  495.                 var reg1 uintB* ptr = unpack_string(obj,&len);
  496.                 # ab ptr kommen len Characters
  497.                 if (len==1) return code_char(ptr[0]);
  498.             } }
  499.             else
  500.             if (posfixnump(obj))
  501.               { var reg1 uintL code = posfixnum_to_L(obj);
  502.                 if (code < char_int_limit)
  503.                   # obj ist ein Fixnum >=0, < char_int_limit
  504.                   return int_char(code);
  505.               }
  506.       # war nichts von allem -> nicht in Character umwandelbar
  507.       return NIL; # NIL als Ergebnis
  508.     }
  509.  
  510. # Character-Namen:
  511. # Nur die Characters mit Font 0 und Bits 0 haben Namen. Unter diesen
  512. # sind alle non-graphic String-Chars und das Space.
  513. # Vom Reader wird allerdings auch die Syntax #\A für das Character A (usw.
  514. # für alle Characters) und die Syntax #\Code231 für das Character mit dem
  515. # Code 231 (dezimal) akzeptiert, dies für alle Characters aus Font 0.
  516.  
  517. # Tabelle der Character-Namen:
  518. # in CONSTOBJ.D definiert,
  519.   #ifdef AMIGA_CHARNAMES
  520.     #define charname_table_length  45  # Länge der Tabelle
  521.     #define charname_table_extra   15  # zusätzlich
  522.     #define charname_table  ((object*)(&object_tab.charname_0)) # Tabelle fängt mit charname_0 an
  523.   #endif
  524.   #ifdef MSDOS_CHARNAMES
  525.     #define charname_table_length  13  # Länge der Tabelle
  526.     #define charname_table_extra   24  # zusätzlich
  527.     #define charname_table  ((object*)(&object_tab.charname_0)) # Tabelle fängt mit charname_0 an
  528.   #endif
  529.   #ifdef UNIX_CHARNAMES
  530.     #define charname_table_length  46  # Länge der Tabelle
  531.     #define charname_table_extra   22  # zusätzlich
  532.     #define charname_table  ((object*)(&object_tab.charname_0bis)) # Tabelle fängt mit charname_0bis an
  533.   #endif
  534. # Tabelle der Codes zu diesen Namen:
  535.   local uintB charname_table_codes [charname_table_length+charname_table_extra]
  536.     #ifdef AMIGA_CHARNAMES
  537.       = { 0,1,2,3,4,5,6,BEL,BS,TAB,NL,11,PG,CR,14,15,16,17,18,19,20,21,22,
  538.           23,24,25,26,ESC,28,29,30,31,' ',127,7,8,9,LF,10,12,13,27,127,RUBOUT,
  539.           155,
  540.           18,20,22,24,28,'A','B','C','D','E','F','G','H','I','J',
  541.         };
  542.     #endif
  543.     #ifdef MSDOS_CHARNAMES
  544.       = { 0,BEL,BS,TAB,NL,11,PG,CR,26,ESC,' ',RUBOUT,LF,
  545.           CR,16,17,18,19,20,22,23,24,25,29,127,
  546.           'A','B','C','D','E','F','G','H','I','J','K','L',
  547.         };
  548.     #endif
  549.     #ifdef UNIX_CHARNAMES
  550.       = { 0,7,BS,TAB,NL,LF,PG,CR,27,32,RUBOUT,127,
  551.           0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,
  552.           20,21,22,23,24,25,26,27,28,29,30,31,32,127,
  553.           16,17,18,19,20,21,22,23,24,25,
  554.           'A','B','C','D','E','F','G','H','I','J','K','L',
  555.         };
  556.     #endif
  557. # Zum Namen charname_table[i] gehört der Code charname_table_codes[i]
  558. # (für 0 <= i < charname_table_length).
  559.  
  560. # UP: Liefert den Namen eines Zeichens.
  561. # char_name(code)
  562. # > uintB code: Ascii-Code eines Zeichens
  563. # < ergebnis: Simple-String (Name dieses Zeichens) oder NIL
  564.   global object char_name (uintB code);
  565.   global object char_name(code)
  566.     var reg1 uintB code;
  567.     { var reg4 uintB* codes_ptr = &charname_table_codes[0];
  568.       var reg3 object* strings_ptr = &charname_table[0];
  569.       var reg2 uintC count;
  570.       dotimesC(count,charname_table_length,
  571.         { if (code == *codes_ptr++) goto found; # code mit charname_table_codes[i] vergleichen
  572.           strings_ptr++;
  573.         });
  574.       # nicht gefunden
  575.       return NIL;
  576.       found: # gefunden
  577.         return *strings_ptr; # String charname_table[i] aus der Tabelle holen
  578.     }
  579.  
  580. # UP: Bestimmt das Character mit einem gegebenen Namen
  581. # name_char(string)
  582. # > string: String
  583. # < ergebnis: Character mit diesem Namen, oder NIL falls keins existiert
  584.   global object name_char (object string);
  585.   global object name_char(string)
  586.     var reg3 object string;
  587.     { var reg4 uintB* codes_ptr = &charname_table_codes[0];
  588.       var reg3 object* strings_ptr = &charname_table[0];
  589.       var reg2 uintC count;
  590.       dotimesC(count,charname_table_length,
  591.         { if (string_equal(string,*strings_ptr++)) goto found; # string mit charname_table[i] vergleichen
  592.           codes_ptr++;
  593.         });
  594.       dotimesC(count,charname_table_extra,
  595.         { if (string_equal(string,*strings_ptr++)) goto found_extra; # string mit charname_table[i] vergleichen
  596.           codes_ptr++;
  597.         });
  598.       # kein Character mit diesem Namen gefunden
  599.       return NIL;
  600.       found: # gefunden
  601.         return code_char(*codes_ptr); # Code charname_table_codes[i] aus der Tabelle holen
  602.       found_extra: # gefunden unter den Extra-Namen
  603.         return int_char((cint)(*codes_ptr << char_code_shift_c) | char_hyper_c); # hier mit Hyper-Bit
  604.     }
  605.  
  606. LISPFUNN(standard_char_p,1) # (STANDARD-CHAR-P char), CLTL S. 234
  607. # (standard-char-p char) ==
  608. #   (or (char= char #\Newline) (char<= #\Space char #\~))
  609. # Standard-Chars sind die mit einem Code c, mit
  610. #       $20 <= c <= $7E oder c = NL.
  611.   { var reg2 object arg = popSTACK(); # Argument
  612.     if (!(charp(arg))) fehler_char(arg); # muß ein Character sein
  613.     { var reg1 cint ch = char_int(arg);
  614.       if ((('~' >= ch) && (ch >= ' ')) || (ch == NL))
  615.         { value1 = T; mv_count=1; }
  616.         else
  617.         { value1 = NIL; mv_count=1; }
  618.   } }
  619.  
  620. LISPFUNN(graphic_char_p,1) # (GRAPHIC-CHAR-P char), CLTL S. 234
  621.   { var reg2 object arg = popSTACK(); # Argument
  622.     if (!(charp(arg))) fehler_char(arg); # muß ein Character sein
  623.     { var reg1 cint ch = char_int(arg);
  624.       if (ch >= char_code_limit) goto no; # kein String-Char -> nein
  625.       if (graphic_char_p(ch)) goto yes; else goto no;
  626.     }
  627.     yes: value1 = T; mv_count=1; return;
  628.     no: value1 = NIL; mv_count=1; return;
  629.   }
  630.  
  631. LISPFUNN(string_char_p,1) # (STRING-CHAR-P char), CLTL S. 235
  632. # String-Chars sind die mit einem Code c, mit 0 <= c < $100.
  633.   { var reg2 object arg = popSTACK(); # Argument
  634.     if (!(charp(arg))) fehler_char(arg); # muß ein Character sein
  635.     { var reg1 cint ch = char_int(arg);
  636.       if (ch >= char_code_limit) goto no;
  637.       goto yes;
  638.     }
  639.     yes: value1 = T; mv_count=1; return;
  640.     no: value1 = NIL; mv_count=1; return;
  641.   }
  642.  
  643. LISPFUNN(alpha_char_p,1) # (ALPHA-CHAR-P char), CLTL S. 235
  644. # Nur String-Chars sind alphabetisch, auf sie wird ALPHAP angewandt
  645.   { var reg2 object arg = popSTACK(); # Argument
  646.     if (!(charp(arg))) fehler_char(arg); # muß ein Character sein
  647.     { var reg1 cint ch = char_int(arg);
  648.       if (ch >= char_code_limit) goto no; # kein String-Char -> nein
  649.       if (alphap(ch)) goto yes; else goto no;
  650.     }
  651.     yes: value1 = T; mv_count=1; return;
  652.     no: value1 = NIL; mv_count=1; return;
  653.   }
  654.  
  655. LISPFUNN(upper_case_p,1) # (UPPER-CASE-P char), CLTL S. 235
  656. # Upper-case-Characters sind die mit einem Code c mit 0 <= c < $100, die
  657. # von (downcase char) verschieden sind.
  658.   { var reg2 object arg = popSTACK(); # Argument
  659.     if (!(charp(arg))) fehler_char(arg); # muß ein Character sein
  660.     { var reg1 cint ch = char_int(arg);
  661.       if (ch >= char_code_limit) goto no; # kein String-Char -> nein
  662.       if (!(down_case(ch)==ch)) goto yes; else goto no;
  663.     }
  664.     yes: value1 = T; mv_count=1; return;
  665.     no: value1 = NIL; mv_count=1; return;
  666.   }
  667.  
  668. LISPFUNN(lower_case_p,1) # (LOWER-CASE-P char), CLTL S. 235
  669. # Lower-case-Characters sind die mit einem Code c mit 0 <= c < $100, die
  670. # von (upcase char) verschieden sind.
  671.   { var reg2 object arg = popSTACK(); # Argument
  672.     if (!(charp(arg))) fehler_char(arg); # muß ein Character sein
  673.     { var reg1 cint ch = char_int(arg);
  674.       if (ch >= char_code_limit) goto no; # kein String-Char -> nein
  675.       if (!(up_case(ch)==ch)) goto yes; else goto no;
  676.     }
  677.     yes: value1 = T; mv_count=1; return;
  678.     no: value1 = NIL; mv_count=1; return;
  679.   }
  680.  
  681. LISPFUNN(both_case_p,1) # (BOTH-CASE-P char), CLTL S. 235
  682. # (both-case-p char) == (or (upper-case-p char) (lower-case-p char))
  683. # Both-case-Characters sind die mit einem Code c mit 0 <= c < $100, bei denen
  684. # (downcase char) und (upcase char) verschieden sind.
  685.   { var reg2 object arg = popSTACK(); # Argument
  686.     if (!(charp(arg))) fehler_char(arg); # muß ein Character sein
  687.     { var reg1 cint ch = char_int(arg);
  688.       if (ch >= char_code_limit) goto no; # kein String-Char -> nein
  689.       if (!(down_case(ch)==up_case(ch))) goto yes; else goto no;
  690.     }
  691.     yes: value1 = T; mv_count=1; return;
  692.     no: value1 = NIL; mv_count=1; return;
  693.   }
  694.  
  695. # UP: Uberprüft ein optionales Radix-Argument
  696. # test_radix_arg()
  697. # > STACK_0: Argument, Default ist 10
  698. # > subr_self: Aufrufer (ein SUBR)
  699. # < ergebnis: Radix, ein Integer >=2, <=36
  700. # erhöht STACK um 1
  701.   local uintWL test_radix_arg (void);
  702.   local uintWL test_radix_arg()
  703.     { var reg1 object arg = popSTACK(); # Argument
  704.       if (eq(arg,unbound)) { return 10; }
  705.       if (posfixnump(arg))
  706.         { var reg2 uintL radix = posfixnum_to_L(arg);
  707.           if ((2 <= radix) && (radix <= 36)) return radix;
  708.         }
  709.       # Fehler.
  710.       pushSTACK(arg); # Wert für Slot DATUM von TYPE-ERROR
  711.       pushSTACK(O(type_radix)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  712.       pushSTACK(arg); pushSTACK(TheSubr(subr_self)->name);
  713.       //: DEUTSCH "~: Als Zahlsystembasis sind nur Integers zwischen 2 und 36 zulässig, nicht ~."
  714.       //: ENGLISH "~: the radix must be an integer between 2 and 36, not ~"
  715.       //: FRANCAIS "~: Seuls les entiers compris entre 2 et 36 sont possible comme base et non ~."
  716.       fehler(type_error,GETTEXT("~: the radix must be an integer between 2 and 36, not ~"));
  717.     }
  718.  
  719. LISPFUN(digit_char_p,1,1,norest,nokey,0,NIL)
  720. # (DIGIT-CHAR-P char [radix]), CLTL S. 236
  721. # Methode:
  722. # Test, ob radix ein Integer >=2 und <=36 ist.
  723. # char muß ein String-Char <= 'z' sein, sonst NIL als Ergebnis.
  724. # Falls radix<=10: c muß >= '0' und < '0'+radix sein, sonst NIL.
  725. # Falls radix>=10: c muß >= '0' und <= '9' oder
  726. #                  (upcase c) muß >= 'A' und < 'A'-10+radix sein, sonst NIL.
  727.   { var reg1 uintWL radix = test_radix_arg(); # Zahlbasis, >=2, <=36
  728.     var reg2 object arg = popSTACK(); # Argument
  729.     if (!(charp(arg))) fehler_char(arg); # muß ein Character sein
  730.     { var reg1 cint ch = char_int(arg);
  731.       if (ch > 'z') goto no; # kein String-Char oder zu groß -> nein
  732.       if (ch >= 'a') { ch -= 'a'-'A'; } # Character >='a',<='z' in Großbuchstaben wandeln
  733.       # Nun ist $00 <= ch <= $60.
  734.       if (ch < '0') goto no;
  735.       # $30 <= ch <= $60 in Zahlwert umwandeln:
  736.       if (ch <= '9') { ch = ch - '0'; }
  737.       else if (ch >= 'A') { ch = ch - 'A' + 10; }
  738.       else goto no;
  739.       # Nun ist ch der Zahlwert der Ziffer, >=0, <=41.
  740.       if (ch >= radix) goto no; # nur gültig, falls 0 <= ch < radix.
  741.       # Wert als Fixnum zurück:
  742.       value1 = fixnum(ch); mv_count=1; return;
  743.     }
  744.     no: value1 = NIL; mv_count=1; return;
  745.   }
  746.  
  747. LISPFUNN(alphanumericp,1) # (ALPHANUMERICP char), CLTL S. 236
  748. # Alphanumerische Characters sind die Ziffern '0',...,'9' und die
  749. # alphabetischen Characters.
  750.   { var reg2 object arg = popSTACK(); # Argument
  751.     if (!(charp(arg))) fehler_char(arg); # muß ein Character sein
  752.     { var reg1 cint ch = char_int(arg);
  753.       if (ch >= char_code_limit) goto no; # kein String-Char -> nein
  754.       if (alphanumericp(ch)) goto yes; else goto no;
  755.     }
  756.     yes: value1 = T; mv_count=1; return;
  757.     no: value1 = NIL; mv_count=1; return;
  758.   }
  759.  
  760. # Zeichenvergleichsfunktionen:
  761. # Die Vergleiche CHAR=,... vergleichen das gesamte oint (oder äquivalent,
  762. # nur das cint, aber inclusive Font und Bits).
  763. # Die Vergleiche CHAR-EQUAL,... ignorieren Font und Bits, wandeln die
  764. # Ascii-Codes in Großbuchstaben um und vergleichen diese.
  765.  
  766. # UP: Testet, ob alle argcount+1 Argumente unterhalb von args_pointer
  767. # Characters sind. Wenn nein, Error.
  768. # > argcount: Argumentezahl-1
  769. # > args_pointer: Pointer über die Argumente
  770. # > subr_self: Aufrufer (ein SUBR)
  771.   local void test_char_args (uintC argcount, object* args_pointer);
  772.   local void test_char_args(argcount,args_pointer)
  773.     var reg2 uintC argcount;
  774.     var reg1 object* args_pointer;
  775.     { dotimespC(argcount,argcount+1,
  776.         { var reg3 object arg = NEXT(args_pointer); # nächstes Argument
  777.           if (!(charp(arg))) fehler_char(arg); # muß ein Character sein
  778.         });
  779.     }
  780.  
  781. # UP: Testet, ob alle argcount+1 Argumente unterhalb von args_pointer
  782. # Characters sind. Wenn nein, Error. Streicht von ihnen Bits und Font
  783. # und wandelt sie in Großbuchstaben um.
  784. # > argcount: Argumentezahl-1
  785. # > args_pointer: Pointer über die Argumente
  786. # > subr_self: Aufrufer (ein SUBR)
  787.   local void test_char_args_upcase (uintC argcount, object* args_pointer);
  788.   local void test_char_args_upcase(argcount,args_pointer)
  789.     var reg2 uintC argcount;
  790.     var reg1 object* args_pointer;
  791.     { dotimespC(argcount,argcount+1,
  792.         { var reg3 object* argptr = &NEXT(args_pointer);
  793.           var reg3 object arg = *argptr; # nächstes Argument
  794.           if (!(charp(arg))) fehler_char(arg); # muß ein Character sein
  795.           *argptr = code_char(up_case(char_code(arg))); # durch Großbuchstaben ersetzen
  796.         });
  797.     }
  798.  
  799. # UP: (CHAR= char {char}) bei überprüften Argumenten
  800.   local Values char_gleich (uintC argcount, object* args_pointer);
  801.   local Values char_gleich (argcount,args_pointer)
  802.     var reg2 uintC argcount;
  803.     var reg1 object* args_pointer;
  804.     # Methode:
  805.     # n+1 Argumente Arg[0..n].
  806.     # x:=Arg[n].
  807.     # for i:=n-1 to 0 step -1 do ( if Arg[i]/=x then return(NIL) ), return(T).
  808.     { var reg3 object x = popSTACK(); # letztes Argument nehmen
  809.       dotimesC(argcount,argcount, { if (!eq(popSTACK(),x)) goto no; } );
  810.       yes: value1 = T; goto ok;
  811.       no: value1 = NIL; goto ok;
  812.       ok: mv_count=1; set_args_end_pointer(args_pointer);
  813.     }
  814.  
  815. # UP: (CHAR/= char {char}) bei überprüften Argumenten
  816.   local Values char_ungleich (uintC argcount, object* args_pointer);
  817.   local Values char_ungleich (argcount,args_pointer)
  818.     var reg6 uintC argcount;
  819.     var reg5 object* args_pointer;
  820.     # Methode:
  821.     # n+1 Argumente Arg[0..n].
  822.     # for j:=n-1 to 0 step -1 do
  823.     #   x:=Arg[j+1], for i:=j to 0 step -1 do
  824.     #                   if Arg[i]=x then return(NIL),
  825.     # return(T).
  826.     { var reg4 object* arg_j_ptr = args_end_pointer;
  827.       var reg3 uintC j = argcount;
  828.       until (j==0)
  829.         { var reg2 object x = BEFORE(arg_j_ptr); # nächst-letztes Argument
  830.           # mit allen Argumenten davor vergleichen:
  831.           var reg1 object* arg_i_ptr = arg_j_ptr;
  832.           var reg1 uintC i;
  833.           dotimespC(i,j, { if (eq(BEFORE(arg_i_ptr),x)) goto no; } );
  834.           j--;
  835.         }
  836.       yes: value1 = T; goto ok;
  837.       no: value1 = NIL; goto ok;
  838.       ok: mv_count=1; set_args_end_pointer(args_pointer);
  839.     }
  840.  
  841. # UP: (CHAR< char {char}) bei überprüften Argumenten
  842.   local Values char_kleiner (uintC argcount, object* args_pointer);
  843.   local Values char_kleiner (argcount,args_pointer)
  844.     var reg3 uintC argcount;
  845.     var reg2 object* args_pointer;
  846.     # Methode:
  847.     # n+1 Argumente Arg[0..n].
  848.     # for i:=n to 1 step -1 do
  849.     #    x:=Arg[i], if x char<= Arg[i-1] then return(NIL),
  850.     # return(T).
  851.     { dotimesC(argcount,argcount,
  852.         { var reg1 object x = popSTACK();
  853.           if (as_oint(x) <= as_oint(STACK_0)) goto no;
  854.         });
  855.       yes: value1 = T; goto ok;
  856.       no: value1 = NIL; goto ok;
  857.       ok: mv_count=1; set_args_end_pointer(args_pointer);
  858.     }
  859.  
  860. # UP: (CHAR> char {char}) bei überprüften Argumenten
  861.   local Values char_groesser (uintC argcount, object* args_pointer);
  862.   local Values char_groesser (argcount,args_pointer)
  863.     var reg3 uintC argcount;
  864.     var reg2 object* args_pointer;
  865.     # Methode:
  866.     # n+1 Argumente Arg[0..n].
  867.     # for i:=n to 1 step -1 do
  868.     #    x:=Arg[i], if x char>= Arg[i-1] then return(NIL),
  869.     # return(T).
  870.     { dotimesC(argcount,argcount,
  871.         { var reg1 object x = popSTACK();
  872.           if (as_oint(x) >= as_oint(STACK_0)) goto no;
  873.         });
  874.       yes: value1 = T; goto ok;
  875.       no: value1 = NIL; goto ok;
  876.       ok: mv_count=1; set_args_end_pointer(args_pointer);
  877.     }
  878.  
  879. # UP: (CHAR<= char {char}) bei überprüften Argumenten
  880.   local Values char_klgleich (uintC argcount, object* args_pointer);
  881.   local Values char_klgleich (argcount,args_pointer)
  882.     var reg3 uintC argcount;
  883.     var reg2 object* args_pointer;
  884.     # Methode:
  885.     # n+1 Argumente Arg[0..n].
  886.     # for i:=n to 1 step -1 do
  887.     #    x:=Arg[i], if x char< Arg[i-1] then return(NIL),
  888.     # return(T).
  889.     { dotimesC(argcount,argcount,
  890.         { var reg1 object x = popSTACK();
  891.           if (as_oint(x) < as_oint(STACK_0)) goto no;
  892.         });
  893.       yes: value1 = T; goto ok;
  894.       no: value1 = NIL; goto ok;
  895.       ok: mv_count=1; set_args_end_pointer(args_pointer);
  896.     }
  897.  
  898. # UP: (CHAR>= char {char}) bei überprüften Argumenten
  899.   local Values char_grgleich (uintC argcount, object* args_pointer);
  900.   local Values char_grgleich (argcount,args_pointer)
  901.     var reg3 uintC argcount;
  902.     var reg2 object* args_pointer;
  903.     # Methode:
  904.     # n+1 Argumente Arg[0..n].
  905.     # for i:=n to 1 step -1 do
  906.     #    x:=Arg[i], if x char> Arg[i-1] then return(NIL),
  907.     # return(T).
  908.     { dotimesC(argcount,argcount,
  909.         { var reg1 object x = popSTACK();
  910.           if (as_oint(x) > as_oint(STACK_0)) goto no;
  911.         });
  912.       yes: value1 = T; goto ok;
  913.       no: value1 = NIL; goto ok;
  914.       ok: mv_count=1; set_args_end_pointer(args_pointer);
  915.     }
  916.  
  917. LISPFUN(char_gleich,1,0,rest,nokey,0,NIL) # (CHAR= char {char}), CLTL S. 237
  918.   { var reg2 object* args_pointer = rest_args_pointer STACKop 1;
  919.     test_char_args(argcount,args_pointer);
  920.     return_Values char_gleich(argcount,args_pointer);
  921.   }
  922.  
  923. LISPFUN(char_ungleich,1,0,rest,nokey,0,NIL) # (CHAR/= char {char}), CLTL S. 237
  924.   { var reg2 object* args_pointer = rest_args_pointer STACKop 1;
  925.     test_char_args(argcount,args_pointer);
  926.     return_Values char_ungleich(argcount,args_pointer);
  927.   }
  928.  
  929. LISPFUN(char_kleiner,1,0,rest,nokey,0,NIL) # (CHAR< char {char}), CLTL S. 237
  930.   { var reg2 object* args_pointer = rest_args_pointer STACKop 1;
  931.     test_char_args(argcount,args_pointer);
  932.     return_Values char_kleiner(argcount,args_pointer);
  933.   }
  934.  
  935. LISPFUN(char_groesser,1,0,rest,nokey,0,NIL) # (CHAR> char {char}), CLTL S. 237
  936.   { var reg2 object* args_pointer = rest_args_pointer STACKop 1;
  937.     test_char_args(argcount,args_pointer);
  938.     return_Values char_groesser(argcount,args_pointer);
  939.   }
  940.  
  941. LISPFUN(char_klgleich,1,0,rest,nokey,0,NIL) # (CHAR<= char {char}), CLTL S. 237
  942.   { var reg2 object* args_pointer = rest_args_pointer STACKop 1;
  943.     test_char_args(argcount,args_pointer);
  944.     return_Values char_klgleich(argcount,args_pointer);
  945.   }
  946.  
  947. LISPFUN(char_grgleich,1,0,rest,nokey,0,NIL) # (CHAR>= char {char}), CLTL S. 237
  948.   { var reg2 object* args_pointer = rest_args_pointer STACKop 1;
  949.     test_char_args(argcount,args_pointer);
  950.     return_Values char_grgleich(argcount,args_pointer);
  951.   }
  952.  
  953. LISPFUN(char_equal,1,0,rest,nokey,0,NIL) # (CHAR-EQUAL char {char}), CLTL S. 239
  954.   { var reg2 object* args_pointer = rest_args_pointer STACKop 1;
  955.     test_char_args_upcase(argcount,args_pointer);
  956.     return_Values char_gleich(argcount,args_pointer);
  957.   }
  958.  
  959. LISPFUN(char_not_equal,1,0,rest,nokey,0,NIL) # (CHAR-NOT-EQUAL char {char}), CLTL S. 239
  960.   { var reg2 object* args_pointer = rest_args_pointer STACKop 1;
  961.     test_char_args_upcase(argcount,args_pointer);
  962.     return_Values char_ungleich(argcount,args_pointer);
  963.   }
  964.  
  965. LISPFUN(char_lessp,1,0,rest,nokey,0,NIL) # (CHAR-LESSP char {char}), CLTL S. 239
  966.   { var reg2 object* args_pointer = rest_args_pointer STACKop 1;
  967.     test_char_args_upcase(argcount,args_pointer);
  968.     return_Values char_kleiner(argcount,args_pointer);
  969.   }
  970.  
  971. LISPFUN(char_greaterp,1,0,rest,nokey,0,NIL) # (CHAR-GREATERP char {char}), CLTL S. 239
  972.   { var reg2 object* args_pointer = rest_args_pointer STACKop 1;
  973.     test_char_args_upcase(argcount,args_pointer);
  974.     return_Values char_groesser(argcount,args_pointer);
  975.   }
  976.  
  977. LISPFUN(char_not_greaterp,1,0,rest,nokey,0,NIL) # (CHAR-NOT-GREATERP char {char}), CLTL S. 239
  978.   { var reg2 object* args_pointer = rest_args_pointer STACKop 1;
  979.     test_char_args_upcase(argcount,args_pointer);
  980.     return_Values char_klgleich(argcount,args_pointer);
  981.   }
  982.  
  983. LISPFUN(char_not_lessp,1,0,rest,nokey,0,NIL) # (CHAR-NOT-LESSP char {char}), CLTL S. 239
  984.   { var reg2 object* args_pointer = rest_args_pointer STACKop 1;
  985.     test_char_args_upcase(argcount,args_pointer);
  986.     return_Values char_grgleich(argcount,args_pointer);
  987.   }
  988.  
  989. LISPFUNN(char_code,1) # (CHAR-CODE char), CLTL S. 239
  990.   { var reg1 object arg = popSTACK(); # Argument
  991.     if (!(charp(arg))) fehler_char(arg); # muß ein Character sein
  992.     value1 = fixnum(char_code(arg)); # Ascii-Code als Fixnum
  993.     mv_count=1;
  994.   }
  995.  
  996. LISPFUNN(char_bits,1) # (CHAR-BITS char), CLTL S. 240
  997.   { var reg1 object arg = popSTACK(); # Argument
  998.     if (!(charp(arg))) fehler_char(arg); # muß ein Character sein
  999.     value1 = fixnum(((char_int(arg) & char_bits_mask_c) >> char_bits_shift_c));
  1000.     mv_count=1;
  1001.   }
  1002.  
  1003. LISPFUNN(char_font,1) # (CHAR-FONT char), CLTL S. 240
  1004.   { var reg1 object arg = popSTACK(); # Argument
  1005.     if (!(charp(arg))) fehler_char(arg); # muß ein Character sein
  1006.     value1 = fixnum(((char_int(arg) & char_font_mask_c) >> char_font_shift_c));
  1007.     mv_count=1;
  1008.   }
  1009.  
  1010. # UP: Überprüft ein optionales Font-Argument
  1011. # > STACK_0: Argument, Default ist 0
  1012. # > subr_self: Aufrufer (ein SUBR)
  1013. # < ergebnis: Font, ein Integer
  1014. # erhöht STACK um 1
  1015.   local object test_font_arg (void);
  1016.   local object test_font_arg()
  1017.     { var reg1 object arg = popSTACK(); # font-Argument
  1018.       if (eq(arg,unbound)) { return Fixnum_0; } # 0 als Default
  1019.       if (integerp(arg)) { return arg; }
  1020.       # arg ist kein Integer.
  1021.       pushSTACK(arg); # Wert für Slot DATUM von TYPE-ERROR
  1022.       pushSTACK(S(integer)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  1023.       pushSTACK(arg); pushSTACK(TheSubr(subr_self)->name);
  1024.       //: DEUTSCH "~: Font-Argument muß ein Integer sein, nicht ~."
  1025.       //: ENGLISH "~: the font argument should be an integer, not ~"
  1026.       //: FRANCAIS "~: L'argument fonte doit être un entier et non ~."
  1027.       fehler(type_error,GETTEXT("~: the font argument should be an integer, not ~"));
  1028.     }
  1029.  
  1030. # UP: Überprüft ein optionales Bits-Argument
  1031. # > STACK_0: Argument, Default ist 0
  1032. # > subr_self: Aufrufer (ein SUBR)
  1033. # < ergebnis: Bits, ein Integer
  1034. # erhöht STACK um 1
  1035.   local object test_bits_arg (void);
  1036.   local object test_bits_arg()
  1037.     { var reg1 object arg = popSTACK(); # bits-Argument
  1038.       if (eq(arg,unbound)) { return Fixnum_0; } # 0 als Default
  1039.       if (integerp(arg)) { return arg; }
  1040.       # arg ist kein Integer.
  1041.       pushSTACK(arg); # Wert für Slot DATUM von TYPE-ERROR
  1042.       pushSTACK(S(integer)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  1043.       pushSTACK(arg); pushSTACK(TheSubr(subr_self)->name);
  1044.       //: DEUTSCH "~: Bits-Argument muß ein Integer sein, nicht ~."
  1045.       //: ENGLISH "~: the bits argument should be an integer, not ~"
  1046.       //: FRANCAIS "~: L'argument bits doit être un entier et non ~."
  1047.       fehler(type_error,GETTEXT("~: the bits argument should be an integer, not ~"));
  1048.     }
  1049.  
  1050. LISPFUN(code_char,1,2,norest,nokey,0,NIL)
  1051. # (CODE-CHAR code [bits] [font]), CLTL S. 240
  1052.   { var reg5 object fontobj = test_font_arg(); # Font-Argument, ein Integer
  1053.     var reg6 object bitsobj = test_bits_arg(); # Bits-Argument, ein Integer
  1054.     var reg4 object codeobj = popSTACK(); # code-Argument
  1055.     if (!integerp(codeobj))
  1056.       { # code-Argument ist kein Integer.
  1057.         pushSTACK(codeobj); # Wert für Slot DATUM von TYPE-ERROR
  1058.         pushSTACK(S(integer)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  1059.         pushSTACK(codeobj); pushSTACK(TheSubr(subr_self)->name);
  1060.         //: DEUTSCH "~: Code-Argument muß ein Integer sein, nicht ~."
  1061.         //: ENGLISH "~: the code argument should be an integer, not ~"
  1062.         //: FRANCAIS "~: L'argument code doit être un entier et non ~."
  1063.         fehler(type_error,GETTEXT("~: the code argument should be an integer, not ~"));
  1064.       }
  1065.     # codeobj ist jetzt ein Integer.
  1066.     { var reg3 uintL font;
  1067.       var reg2 uintL bits;
  1068.       var reg1 uintL code;
  1069.       # Teste, ob  0 <= font < char_font_limit
  1070.       #       und  0 <= bits < char_bits_limit
  1071.       #       und  0 <= code < char_code_limit :
  1072.       if ( (posfixnump(fontobj)) && ((font = posfixnum_to_L(fontobj)) < char_font_limit)
  1073.         && (posfixnump(bitsobj)) && ((bits = posfixnum_to_L(bitsobj)) < char_bits_limit)
  1074.         && (posfixnump(codeobj)) && ((code = posfixnum_to_L(codeobj)) < char_code_limit)
  1075.          )
  1076.         { # Bastle neues Character:
  1077.           value1 = int_char( (font << char_font_shift_c) |
  1078.                              (bits << char_bits_shift_c) |
  1079.                              (code << char_code_shift_c) );
  1080.           mv_count=1;
  1081.         }
  1082.         else
  1083.         { value1 = NIL; mv_count=1; } # sonst Wert NIL
  1084.   } }
  1085.  
  1086. LISPFUN(make_char,1,2,norest,nokey,0,NIL)
  1087. # (MAKE-CHAR char [bits] [font]), CLTL S. 240
  1088.   { var reg5 object fontobj = test_font_arg(); # Font-Argument, ein Integer
  1089.     var reg6 object bitsobj = test_bits_arg(); # Bits-Argument, ein Integer
  1090.     var reg4 object charobj = popSTACK(); # char-Argument
  1091.     if (!(charp(charobj))) fehler_char(charobj);
  1092.     { var reg3 uintL font;
  1093.       var reg2 uintL bits;
  1094.       # Teste, ob  0 <= font < char_font_limit
  1095.       #       und  0 <= bits < char_bits_limit :
  1096.       if ( (posfixnump(fontobj)) && ((font = posfixnum_to_L(fontobj)) < char_font_limit)
  1097.         && (posfixnump(bitsobj)) && ((bits = posfixnum_to_L(bitsobj)) < char_bits_limit)
  1098.          )
  1099.         { # Bastle neues Character:
  1100.           value1 = int_char( (font << char_font_shift_c) |
  1101.                              (bits << char_bits_shift_c) |
  1102.                              (char_code(charobj) << char_code_shift_c) );
  1103.           mv_count=1;
  1104.         }
  1105.         else
  1106.         { value1 = NIL; mv_count=1; } # sonst Wert NIL
  1107.   } }
  1108.  
  1109. LISPFUNN(character,1) # (CHARACTER object), CLTL S. 241
  1110.   { var reg1 object try = coerce_char(STACK_0); # Argument in Character umwandeln
  1111.     if (nullp(try)) # erfolglos?
  1112.       { # Argument noch in STACK_0
  1113.         pushSTACK(TheSubr(subr_self)->name);
  1114.         //: DEUTSCH "~: ~ kann nicht in ein Character umgewandelt werden."
  1115.         //: ENGLISH "~: cannot coerce ~ to a character"
  1116.         //: FRANCAIS "~: ~ ne peut pas être transformé en caractère."
  1117.         fehler(error,GETTEXT("~: cannot coerce ~ to a character"));
  1118.       }
  1119.       else
  1120.       { value1 = try; mv_count=1; skipSTACK(1); }
  1121.   }
  1122.  
  1123. LISPFUNN(char_upcase,1) # (CHAR-UPCASE char), CLTL S. 241
  1124.   { var reg2 object arg = popSTACK(); # char-Argument
  1125.     if (!(charp(arg))) fehler_char(arg); # muß ein Character sein
  1126.     { var reg1 cint ch = char_int(arg);
  1127.       value1 =
  1128.         ( (ch >= char_code_limit)
  1129.           ? arg # kein String-Char, also Font oder Bits /=0 -> tut sich nichts
  1130.           : int_char(up_case(ch)) # sonst in Großbuchstaben umwandeln
  1131.         );
  1132.       mv_count=1;
  1133.   } }
  1134.  
  1135. LISPFUNN(char_downcase,1) # (CHAR-DOWNCASE char), CLTL S. 241
  1136.   { var reg2 object arg = popSTACK(); # char-Argument
  1137.     if (!(charp(arg))) fehler_char(arg); # muß ein Character sein
  1138.     { var reg1 cint ch = char_int(arg);
  1139.       value1 =
  1140.         ( (ch >= char_code_limit)
  1141.           ? arg # kein String-Char, also Font oder Bits /=0 -> tut sich nichts
  1142.           : int_char(down_case(ch)) # sonst in Kleinbuchstaben umwandeln
  1143.         );
  1144.       mv_count=1;
  1145.   } }
  1146.  
  1147. LISPFUN(digit_char,1,2,norest,nokey,0,NIL)
  1148. # (DIGIT-CHAR weight [radix] [font]), CLTL S. 241
  1149.   # Methode:
  1150.   # Alles müssen Integers sein, radix zwischen 2 und 36.
  1151.   # Falls font=0 und 0 <= weight < radix, konstruiere
  1152.   #     ein String-Char aus '0',...,'9','A',...,'Z' mit Wert weight.
  1153.   # Sonst Wert NIL. (Denn Characters mit font/=0 erfüllen nicht DIGIT-CHAR-P.)
  1154.   { var reg4 object font = test_font_arg(); # Font-Argument, ein Integer
  1155.     var reg3 uintWL radix = test_radix_arg(); # radix-Argument, >=2, <=36
  1156.     var reg2 object weightobj = popSTACK(); # weight-Argument
  1157.     if (!integerp(weightobj))
  1158.       { # weight-Argument ist kein Integer.
  1159.         pushSTACK(weightobj); # Wert für Slot DATUM von TYPE-ERROR
  1160.         pushSTACK(S(integer)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  1161.         pushSTACK(weightobj); pushSTACK(TheSubr(subr_self)->name);
  1162.         //: DEUTSCH "~: Weight-Argument muß ein Integer sein, nicht ~."
  1163.         //: ENGLISH "~: the weight argument should be an integer, not ~"
  1164.         //: FRANCAIS "~: L'argument poids doit être un entier et non ~."
  1165.         fehler(type_error,GETTEXT("~: the weight argument should be an integer, not ~"));
  1166.       }
  1167.     # weightobj ist jetzt ein Integer.
  1168.     # Teste, ob font=0 und 0<=weight<radix, sonst NIL:
  1169.     { var reg1 uintL weight;
  1170.       if ((eq(font,Fixnum_0))
  1171.           && (posfixnump(weightobj))
  1172.           && ((weight = posfixnum_to_L(weightobj)) < radix)
  1173.          )
  1174.         { weight = weight + '0'; # in Ziffer umwandeln
  1175.           if (weight > '9') { weight += 'A'-'0'-10; } # oder Buchstaben draus machen
  1176.           value1 = code_char(weight); # String-Char basteln (font ist ja =0)
  1177.           mv_count=1;
  1178.         }
  1179.         else
  1180.         { value1 = NIL; mv_count=1; }
  1181.   } }
  1182.  
  1183. LISPFUNN(char_int,1) # (CHAR-INT char), CLTL S. 242
  1184.   { var reg1 object arg = popSTACK(); # char-Argument
  1185.     if (!(charp(arg))) fehler_char(arg); # muß ein Character sein
  1186.     value1 = fixnum(char_int(arg)); mv_count=1;
  1187.   }
  1188.  
  1189. LISPFUNN(int_char,1) # (INT-CHAR integer), CLTL S. 242
  1190.   { var reg2 object arg = popSTACK(); # integer-Argument
  1191.     if (integerp(arg))
  1192.       { # bei 0 <= arg < char_int_limit in Character umwandeln, sonst NIL
  1193.         var reg1 uintL i;
  1194.         if ((posfixnump(arg)) && ((i = posfixnum_to_L(arg)) < char_int_limit))
  1195.           { value1 = int_char(i); mv_count=1; }
  1196.           else
  1197.           { value1 = NIL; mv_count=1; }
  1198.       }
  1199.       else
  1200.       { # arg kein Integer -> Fehler:
  1201.         pushSTACK(arg); # Wert für Slot DATUM von TYPE-ERROR
  1202.         pushSTACK(S(integer)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  1203.         pushSTACK(arg); pushSTACK(TheSubr(subr_self)->name);
  1204.         //: DEUTSCH "~: Argument muß ein Integer sein, nicht ~."
  1205.         //: ENGLISH "~: argument should be an integer, not ~"
  1206.         //: FRANCAIS "~: L'argument doit être un entier et non ~."
  1207.         fehler(type_error,GETTEXT("~: argument should be an integer, not ~"));
  1208.       }
  1209.   }
  1210.  
  1211. LISPFUNN(char_name,1) # (CHAR-NAME char), CLTL S. 242
  1212.   { var reg1 object arg = popSTACK(); # char-Argument
  1213.     if (!(charp(arg))) fehler_char(arg); # muß ein Character sein
  1214.     { var reg1 cint ch = char_int(arg);
  1215.       value1 =
  1216.         ( (ch >= char_code_limit)
  1217.           ? NIL # Characters mit Bits oder Font /=0 haben keinen Namen
  1218.           : char_name(ch)
  1219.         );
  1220.       mv_count=1;
  1221.   } }
  1222.  
  1223. # UP: Überprüft ein Bitname-Argument
  1224. # Das Argument muß eines der Keywords :CONTROL, :META, :SUPER, :HYPER oder
  1225. # einer der Werte der Konstanten CHAR-CONTROL-BIT = 1, CHAR-META-BIT = 2,
  1226. # CHAR-SUPER-BIT = 4, CHAR-HYPER-BIT = 8 sein.
  1227. # test_bitname_arg()
  1228. # > STACK_0: Argument
  1229. # > subr_self: Aufrufer
  1230. # < ergebnis: Maske fürs Bit (genau 1 Bit gesetzt)
  1231. # erhöht STACK um 1
  1232.   local cint test_bitname_arg (void);
  1233.   local cint test_bitname_arg()
  1234.     { var reg5 object arg = popSTACK(); # Argument
  1235.       var reg1 object* bitnamekwptr = &object_tab.bitnamekw_0; # Pointer in Bitnamen-Tabelle
  1236.       var reg2 uintL intval = 1; # Bitname als Integer-Wert
  1237.       var reg4 cint bitmask = bit(char_bits_shift_c); # Bit als cint-Maske
  1238.       var reg3 uintC count;
  1239.       dotimesC(count,char_bits_len_c,
  1240.         { # Hier ist für i=0,...,char_bits_len_c-1:
  1241.           # bitnamekwptr = &object_tab.bitnamekw_i,
  1242.           # intval = 2^i, bitmask = bit(char_bits_shift_c + i).
  1243.           if (eq(arg,*bitnamekwptr++) # ist arg das Bitnamen-Keyword Nummer i
  1244.               || eq(arg,fixnum(intval)) # oder das Fixnum 2^i
  1245.              )
  1246.             goto found; # ja -> fertig
  1247.           intval = intval << 1;
  1248.           bitmask = bitmask << 1;
  1249.         });
  1250.       # Bitname nicht gefunden -> Fehler:
  1251.       pushSTACK(arg); # Wert für Slot DATUM von TYPE-ERROR
  1252.       pushSTACK(O(type_bitname)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  1253.       pushSTACK(arg); pushSTACK(TheSubr(subr_self)->name);
  1254.       //: DEUTSCH "~: Als Bit-Name sind nur :CONTROL, :META, :SUPER, :HYPER zugelassen, nicht ~."
  1255.       //: ENGLISH "~: the only bit names are :CONTROL, :META, :SUPER, :HYPER, not ~"
  1256.       //: FRANCAIS "~: Les seuls noms bits permis sont :CONTROL, :META, :SUPER et :HYPER et non ~."
  1257.       fehler(type_error,GETTEXT("~: the only bit names are :CONTROL, :META, :SUPER, :HYPER, not ~"));
  1258.       found: return bitmask;
  1259.     }
  1260.  
  1261. LISPFUNN(char_bit,2) # (CHAR-BIT char name), CLTL S. 243
  1262.   { var reg2 cint bitmask = test_bitname_arg(); # name als Bitmaske
  1263.     var reg1 object arg = popSTACK(); # char-Argument
  1264.     if (!(charp(arg))) fehler_char(arg); # muß ein Character sein
  1265.     # entsprechendes Bit herausgreifen:
  1266.     if ((char_int(arg) & bitmask)==0) goto no; else goto yes;
  1267.     yes: value1 = T; mv_count=1; return;
  1268.     no: value1 = NIL; mv_count=1; return;
  1269.   }
  1270.  
  1271. LISPFUNN(set_char_bit,3) # (SET-CHAR-BIT char name newvalue), CLTL S. 244
  1272.   { var reg4 object newvalue = popSTACK();
  1273.     var reg2 cint bitmask = test_bitname_arg(); # name als Bitmaske
  1274.     var reg1 object arg = popSTACK(); # char-Argument
  1275.     if (!(charp(arg))) fehler_char(arg); # muß ein Character sein
  1276.    {var reg3 cint ch = char_int(arg);
  1277.     # entsprechendes Bit setzen oder löschen:
  1278.     if (nullp(newvalue)) { ch = ch & ~bitmask; } else { ch = ch | bitmask; }
  1279.     value1 = int_char(ch); mv_count=1;
  1280.   }}
  1281.  
  1282.   local void fehler_index_should_be_NIL_or_integer (const char *name);
  1283.   local void fehler_index_should_be_NIL_or_integer (name)
  1284.     var const char *name;
  1285.     {
  1286.       const char *msg1,*msg2;
  1287.       //: DEUTSCH  ""
  1288.       //: ENGLISH  ""
  1289.       //: FRANCAIS "L'index "
  1290.       msg1 = GETTEXT("start:[index should be NIL or an integer, not ~]");
  1291.       //: DEUTSCH  "Index muß NIL oder ein Integer sein, nicht ~."
  1292.       //: ENGLISH  "index should be NIL or an integer, not ~"
  1293.       //: FRANCAIS " doit être NIL ou un entier et non ~."
  1294.       msg2 = GETTEXT("end:[index should be NIL or an integer, not ~]");
  1295.       fehler4(type_error,"~:  ",name,msg1,msg2);
  1296.     }
  1297.  
  1298.   local void fehler_index_should_be_integer (const char *name);
  1299.   local void fehler_index_should_be_integer (name)
  1300.     var const char *name;
  1301.     {
  1302.       const char *msg1,*msg2;
  1303.       //: DEUTSCH  ""
  1304.       //: ENGLISH  ""
  1305.       //: FRANCAIS "L'index "
  1306.       msg1 = GETTEXT("start:[index should be integer, not ~]");
  1307.       //: DEUTSCH "Index muß ein Integer sein, nicht ~."
  1308.       //: ENGLISH "index should be an integer, not ~" 
  1309.       //: FRANCAIS " doit être un entier et non ~."
  1310.       msg2 = GETTEXT("end:[index should be integer, not ~]");
  1311.       fehler4(type_error,"~:  ",name,msg1,msg2);
  1312.     }
  1313.  
  1314.   local void fehler_index_should_not_be_negative (const char *name);
  1315.   local void fehler_index_should_not_be_negative (name)
  1316.     var const char *name;
  1317.     {
  1318.       const char *msg1,*msg2;
  1319.       //: DEUTSCH  ""
  1320.       //: ENGLISH  ""
  1321.       //: FRANCAIS "L'index "
  1322.       msg1 = GETTEXT("start:[index should not be negative ~]");
  1323.       //: DEUTSCH "Index muß >=0 sein, nicht ~."
  1324.       //: ENGLISH "index should not be negative: ~"
  1325.       //: FRANCAIS "doit être positif ou zéro et non ~."
  1326.       msg2 = GETTEXT("end:[index should not be negative ~]");
  1327.       fehler4(type_error,"~:  ",name,msg1,msg2);
  1328.     }
  1329.  
  1330.   local void fehler_index_should_not_be_greater_than_length_of_string (const char *name);
  1331.   local void fehler_index_should_not_be_greater_than_length_of_string  (name)
  1332.     var const char *name;
  1333.     {
  1334.       const char *msg1,*msg2;
  1335.       //: DEUTSCH  ""
  1336.       //: ENGLISH  ""
  1337.       //: FRANCAIS "L'index "
  1338.       msg1 = GETTEXT("start:[index ~ should not be greater than the length of the string]");
  1339.       //: DEUTSCH "Index ~ darf die Stringlänge nicht überschreiten." 
  1340.       //: ENGLISH "index ~ should not be greater than the length of the string"
  1341.       //: FRANCAIS " ~ ne peut pas être plus grand que la longueur de la chaîne."
  1342.       msg2 = GETTEXT("end:[index ~ should not be greater than the length of the string]");
  1343.       fehler4(type_error,"~:  ",name,msg1,msg2);
  1344.     }
  1345.  
  1346.   local void fehler_index_should_be_less_than_length_of_string (const char *name);
  1347.   local void fehler_index_should_be_less_than_length_of_string  (name)
  1348.     var const char *name;
  1349.     {
  1350.       const char *msg1,*msg2;
  1351.       //: DEUTSCH  ""
  1352.       //: ENGLISH  ""
  1353.       //: FRANCAIS "L'index "
  1354.       msg1 = GETTEXT("start:[index ~ should be less than the length of the string]");
  1355.       //: DEUTSCH "Index ~ muß kleiner als die Stringlänge sein."
  1356.       //: ENGLISH "index ~ should be less than the length of the string"
  1357.       //: FRANCAIS " ~ doit être plus petit que la longueur de la chaîne."
  1358.       msg2 = GETTEXT("end:[index ~ should be less than the length of the string]");
  1359.       fehler4(type_error,"~:  ",name,msg1,msg2);
  1360.     }
  1361.  
  1362. # Macro: Überprüft ein Index-Argument
  1363. # test_index(woher,wohin_zuweisung,def,default,vergleich,grenze,ucname,lcname)
  1364. # woher : expression, woher der Index (als object) kommt.
  1365. # wohin_zuweisung : weist das Ergebnis (als uintL) zu.
  1366. # def : 0 wenn nicht auf Defaultwerte zu testen ist,
  1367. #       1 wenn bei unbound der Default eingesetzt wird,
  1368. #       2 wenn bei unbound oder NIL der Default eingesetzt wird.
  1369. # default : expression, die als Defaultwert in diesem Falle dient.
  1370. # grenze : obere Grenze
  1371. # vergleich : Vergleich mit der oberen Grenze
  1372. # ucname,lcname : Zusätzliche Identifikation des Index in Groß- bzw. Kleinbuchstaben
  1373.   #define test_index(woher,wohin_zuweisung,def,default,vergleich,grenze,index_name)  \
  1374.     { var reg1 object index = woher; # Index-Argument                           \
  1375.       if (def && ((eq(index,unbound)) || ((def==2) && (eq(index,NIL)))))        \
  1376.         { wohin_zuweisung default; }                                            \
  1377.         else                                                                    \
  1378.         { # muß ein Integer sein:                                               \
  1379.           if (!integerp(index))                                                 \
  1380.             { pushSTACK(index); # Wert für Slot DATUM von TYPE-ERROR            \
  1381.               pushSTACK(def==2 ? O(type_end_index) : S(integer)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR \
  1382.               pushSTACK(index); pushSTACK(TheSubr(subr_self)->name);            \
  1383.               if (def==2)                                                       \
  1384.                 fehler_index_should_be_NIL_or_integer(index_name);              \
  1385.               else                                                              \
  1386.                 fehler_index_should_be_integer(index_name);                     \
  1387.             }                                                                   \
  1388.           # index ist ein Integer.                                              \
  1389.           if (!(positivep(index)))                                              \
  1390.             { pushSTACK(index); # Wert für Slot DATUM von TYPE-ERROR            \
  1391.               pushSTACK(O(type_posinteger)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR \
  1392.               pushSTACK(index); pushSTACK(TheSubr(subr_self)->name);            \
  1393.               fehler_index_should_not_be_negative(index_name);                  \
  1394.             }                                                                   \
  1395.           # index ist >=0.                                                      \
  1396.           if (!((posfixnump(index)) &&                                          \
  1397.                 ((wohin_zuweisung posfixnum_to_L(index)) vergleich grenze)      \
  1398.              ) )                                                                \
  1399.             { pushSTACK(index); pushSTACK(TheSubr(subr_self)->name);            \
  1400.               if (0 vergleich 0)                                                \
  1401.                 # "<= grenze" - Vergleich nicht erfüllt                         \
  1402.                 fehler_index_should_not_be_greater_than_length_of_string(index_name); \
  1403.                 else                                                            \
  1404.                 # "< grenze" - Vergleich nicht erfüllt                          \
  1405.                 fehler_index_should_be_less_than_length_of_string(index_name);        \
  1406.             }                                                                   \
  1407.     }   }
  1408.  
  1409. # UP: Überprüft ein Index-Argument für Stringfunktionen
  1410. # > STACK_0: Argument
  1411. # > charptr: Ab hier kommen die Characters des Strings
  1412. # > len: Länge des Strings (< array-total-size-limit)
  1413. # > subr_self: Aufrufer (ein SUBR)
  1414. # < ergebnis: Pointer auf das angesprochene Character
  1415.   local uintB* test_index_arg (uintB* charptr, uintL len);
  1416.   local uintB* test_index_arg(charptr,len)
  1417.     var reg3 uintB* charptr;
  1418.     var reg2 uintL len;
  1419.     { var reg4 uintL i;
  1420.       # i := Index STACK_0, kein Defaultwert nötig, muß <len sein:
  1421.       test_index(STACK_0,i=,0,0,<,len,"");
  1422.       return &charptr[i];
  1423.     }
  1424.  
  1425. LISPFUNN(char,2) # (CHAR string index), CLTL S. 300
  1426.   { var reg3 object string = STACK_1; # string-Argument
  1427.     if (!(stringp(string))) fehler_string(string); # muß ein String sein
  1428.    {var uintL len;
  1429.     var reg2 uintB* charptr = unpack_string(string,&len); # zu den Characters vorrücken
  1430.     charptr = test_index_arg(charptr,len); # zum vom Index angesprochenen Element gehen
  1431.     value1 = code_char(*charptr); mv_count=1; # Character herausgreifen
  1432.     skipSTACK(2);
  1433.   }}
  1434.  
  1435. LISPFUNN(schar,2) # (SCHAR string integer), CLTL S. 300
  1436.   { var reg2 object string = STACK_1; # string-Argument
  1437.     if (!(simple_string_p(string))) fehler_sstring(string); # muß ein Simple-String sein
  1438.     # zum vom Index angesprochenen Element gehen
  1439.    {var reg1 uintB* charptr = test_index_arg(&TheSstring(string)->data[0],TheSstring(string)->length);
  1440.     value1 = code_char(*charptr); mv_count=1; # Character herausgreifen
  1441.     skipSTACK(2);
  1442.   }}
  1443.  
  1444. # UP: Überprüft ein in einen String einzusetzendes Character
  1445. # test_newchar_arg()
  1446. # > STACK_0: Argument
  1447. # > subr_self: Aufrufer (ein SUBR)
  1448. # < ergebnis: Argument als String-Char
  1449. # erhöht STACK um 1
  1450.   local object test_newchar_arg (void);
  1451.   local object test_newchar_arg()
  1452.     { var reg1 object arg = popSTACK(); # Argument
  1453.       if (string_char_p(arg))
  1454.         return arg;
  1455.         else
  1456.         { pushSTACK(arg); # Wert für Slot DATUM von TYPE-ERROR
  1457.           pushSTACK(S(string_char)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  1458.           pushSTACK(arg); pushSTACK(TheSubr(subr_self)->name);
  1459.           //: DEUTSCH "~: Argument muß ein String-Char sein, nicht ~."
  1460.           //: ENGLISH "~: argument should be a string-char, not ~"
  1461.           //: FRANCAIS "~: L'argument doit être de type STRING-CHAR et non ~."
  1462.           fehler(type_error,GETTEXT("~: argument should be a string-char, not ~"));
  1463.         }
  1464.     }
  1465.  
  1466. LISPFUNN(store_char,3) # (SYSTEM::STORE-CHAR string index newchar)
  1467.                        # = (SETF (CHAR string index) newchar), CLTL S. 300
  1468.   { var reg4 object newchar = test_newchar_arg(); # newchar-Argument
  1469.     var reg3 object string = STACK_1; # string-Argument
  1470.     if (!(stringp(string))) fehler_string(string); # muß ein String sein
  1471.    {var uintL len;
  1472.     var reg2 uintB* charptr = unpack_string(string,&len); # zu den Characters vorrücken
  1473.     charptr = test_index_arg(charptr,len); # zum vom Index angesprochenen Element gehen
  1474.     *charptr = char_code(newchar); # Character eintragen
  1475.     value1 = newchar; mv_count=1;
  1476.     skipSTACK(2);
  1477.   }}
  1478.  
  1479. LISPFUNN(store_schar,3) # (SYSTEM::STORE-SCHAR simple-string index newchar)
  1480.                         # = (SETF (SCHAR simple-string index) newchar), CLTL S. 300
  1481.   { var reg4 object newchar = test_newchar_arg(); # newchar-Argument
  1482.     var reg2 object string = STACK_1; # string-Argument
  1483.     if (!(simple_string_p(string))) fehler_sstring(string); # muß ein Simple-String sein
  1484.     # zum vom Index angesprochenen Element gehen
  1485.    {var reg1 uintB* charptr = test_index_arg(&TheSstring(string)->data[0],TheSstring(string)->length);
  1486.     *charptr = char_code(newchar); # Character eintragen
  1487.     value1 = newchar; mv_count=1;
  1488.     skipSTACK(2);
  1489.   }}
  1490.  
  1491. # UP: Überprüft die Grenzen für ein String-Argument
  1492. # test_string_limits(&string,&start,&len)
  1493. # > STACK_2: String-Argument
  1494. # > STACK_1: optionales :start-Argument
  1495. # > STACK_0: optionales :end-Argument
  1496. # > subr_self: Aufrufer (ein SUBR)
  1497. # < object string: String
  1498. # < uintL start: Wert des :start-Arguments
  1499. # < uintL len: Anzahl der angesprochenen Characters
  1500. # < uintB* ergebnis: Ab hier kommen die angesprochenen Characters
  1501. # erhöht STACK um 3
  1502.   global uintB* test_string_limits (object* string_, uintL* start_, uintL* len_);
  1503.   global uintB* test_string_limits(string_,start_,len_)
  1504.     var reg4 object* string_;
  1505.     var reg5 uintL* start_;
  1506.     var reg6 uintL* len_;
  1507.     { var reg3 uintB* charptr;
  1508.       var uintL len;
  1509.       var reg1 uintL start;
  1510.       var reg2 uintL end;
  1511.       # String-Argument überprüfen:
  1512.       { var reg1 object string = STACK_2;
  1513.         if (!(stringp(string))) fehler_string(string);
  1514.         charptr = unpack_string(string,&len);
  1515.         *string_ = string; # String herausgeben
  1516.       }
  1517.       # Nun ist len die Länge (<2^oint_data_len), und ab charptr kommen die Zeichen.
  1518.       # :START-Argument überprüfen:
  1519.         # start := Index STACK_1, Defaultwert 0, muß <=len sein:
  1520.         //: DEUTSCH ":START-"
  1521.         //: ENGLISH ":start-"
  1522.         //: FRANCAIS ":start-"
  1523.         test_index(STACK_1,start=,1,0,<=,len,GETTEXT(":start-"));
  1524.       # start ist jetzt der Wert des :START-Arguments.
  1525.       # :END-Argument überprüfen:
  1526.         # end := Index STACK_0, Defaultwert len, muß <=len sein:
  1527.         //: DEUTSCH ":END-"
  1528.         //: ENGLISH ":end-"
  1529.         //: FRANCAIS ":end-"
  1530.         test_index(STACK_0,end=,2,len,<=,len,GETTEXT(":end-"));
  1531.       # end ist jetzt der Wert des :END-Arguments.
  1532.       # Vergleiche :START und :END Argumente:
  1533.       if (!(start <= end))
  1534.         { pushSTACK(STACK_0); # :END-Index
  1535.           pushSTACK(STACK_2); # :START-Index
  1536.           pushSTACK(TheSubr(subr_self)->name);
  1537.           //: DEUTSCH "~: :START-Index ~ darf den :END-Index ~ nicht überschreiten."
  1538.           //: ENGLISH "~: :start-index ~ must not be greater than :end-index ~"
  1539.           //: FRANCAIS "~: L'index :START ~ ne doit pas être supérieur à l'index :END ~."
  1540.           fehler(error,GETTEXT("~: :start-index ~ must not be greater than :end-index ~"));
  1541.         }
  1542.       skipSTACK(3);
  1543.       # Ergebnisse herausgeben:
  1544.       *start_ = start; *len_ = end-start; return &charptr[start];
  1545.     }
  1546.  
  1547. # UP: Überprüft ein String/Symbol/Character-Argument
  1548. # > obj: Argument
  1549. # > subr_self: Aufrufer (ein SUBR)
  1550. # < ergebnis: Argument als String
  1551. # kann GC auslösen
  1552.   local object test_stringsymchar_arg (object obj);
  1553.   local object test_stringsymchar_arg(obj)
  1554.     var reg1 object obj;
  1555.     { if (stringp(obj)) return obj; # String: unverändert zurück
  1556.       if (symbolp(obj)) return TheSymbol(obj)->pname; # Symbol: Printnamen verwenden
  1557.       if (string_char_p(obj)) # String-Char: einelementigen String daraus machen:
  1558.         { var reg1 object new_string = allocate_string(1);
  1559.           TheSstring(new_string)->data[0] = char_code(obj);
  1560.           return new_string;
  1561.         }
  1562.       pushSTACK(obj); # Wert für Slot DATUM von TYPE-ERROR
  1563.       pushSTACK(O(type_stringsymchar)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  1564.       pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name);
  1565.       //: DEUTSCH "~: Argument muß ein String, Symbol oder String-Char sein, nicht ~."
  1566.       //: ENGLISH "~: argument ~ should be a string, a symbol or a string-char"
  1567.       //: FRANCAIS "~: L'argument ~ doit être de type STRING, SYMBOL ou STRING-CHAR et non ~."
  1568.       fehler(type_error,GETTEXT("~: argument ~ should be a string, a symbol or a string-char"));
  1569.     }
  1570.  
  1571. # UP: Überprüft die Grenzen für 1 String/Symbol-Argument und kopiert es
  1572. # test_1_stringsym_limits(&string,&len)
  1573. # > STACK_2: String/Symbol-Argument
  1574. # > STACK_1: optionales :start-Argument
  1575. # > STACK_0: optionales :end-Argument
  1576. # > subr_self: Aufrufer (ein SUBR)
  1577. # < object string: Kopie des Strings
  1578. # < uintL len: Anzahl der angesprochenen Characters
  1579. # < uintB* ergebnis: Ab hier kommen die angesprochenen Characters
  1580. # erhöht STACK um 3
  1581. # kann GC auslösen
  1582.   local uintB* test_1_stringsym_limits (object* string_, uintL* len_);
  1583.   local uintB* test_1_stringsym_limits(string_,len_)
  1584.     var reg5 object* string_;
  1585.     var reg6 uintL* len_;
  1586.     { var reg4 object string;
  1587.       var reg3 uintL len;
  1588.       var reg1 uintL start;
  1589.       var reg2 uintL end;
  1590.       # String/Symbol-Argument überprüfen:
  1591.       string = test_stringsymchar_arg(STACK_2);
  1592.       len = vector_length(string);
  1593.       # Nun ist len die Länge (<2^oint_data_len).
  1594.       # :START-Argument überprüfen:
  1595.         # start := Index STACK_1, Defaultwert 0, muß <=len sein:
  1596.         //: DEUTSCH ":START-"
  1597.         //: ENGLISH ":start-"
  1598.         //: FRANCAIS ":start-"
  1599.         test_index(STACK_1,start=,1,0,<=,len,GETTEXT(":start-"));
  1600.       # start ist jetzt der Wert des :START-Arguments.
  1601.       # :END-Argument überprüfen:
  1602.         # end := Index STACK_0, Defaultwert len, muß <=len sein:
  1603.         //: DEUTSCH ":END-"
  1604.         //: ENGLISH ":end-"
  1605.         //: FRANCAIS ":end-"
  1606.         test_index(STACK_0,end=,2,len,<=,len,GETTEXT(":end-"));
  1607.       # end ist jetzt der Wert des :END-Arguments.
  1608.       # Vergleiche :START und :END Argumente:
  1609.       if (!(start <= end))
  1610.         { pushSTACK(STACK_0); # :END-Index
  1611.           pushSTACK(STACK_2); # :START-Index
  1612.           pushSTACK(TheSubr(subr_self)->name);
  1613.           //: DEUTSCH "~: :START-Index ~ darf den :END-Index ~ nicht überschreiten."
  1614.           //: ENGLISH "~: :start-index ~ must not be greater than :end-index ~"
  1615.           //: FRANCAIS "~: L'index :START ~ ne doit pas être supérieur à l'index :END ~."
  1616.           fehler(error,GETTEXT("~: :start-index ~ must not be greater than :end-index ~"));
  1617.         }
  1618.       skipSTACK(3);
  1619.       # String kopieren und Ergebnisse herausgeben:
  1620.       *string_ = string = copy_string(string); # String kopieren
  1621.       *len_ = end-start; return &TheSstring(string)->data[start];
  1622.     }
  1623.  
  1624. # UP: Überprüft die Grenzen für 2 String/Symbol-Argumente
  1625. # test_2_stringsym_limits(&charptr1,&len1,&charptr2,&len2)
  1626. # > STACK_5: String/Symbol-Argument1
  1627. # > STACK_4: String/Symbol-Argument2
  1628. # > STACK_3: optionales :start1-Argument
  1629. # > STACK_2: optionales :end1-Argument
  1630. # > STACK_1: optionales :start2-Argument
  1631. # > STACK_0: optionales :end2-Argument
  1632. # > subr_self: Aufrufer (ein SUBR)
  1633. # < uintB* charptr1: Ab hier kommen die angesprochenen Characters im String1
  1634. # < uintB* charptr1+1: Ab hier kommen die Characters im String1
  1635. # < uintL len1: Anzahl der angesprochenen Characters im String1
  1636. # < uintB* charptr2: Ab hier kommen die angesprochenen Characters im String2
  1637. # < uintL len2: Anzahl der angesprochenen Characters im String2
  1638. # < ergebnis: Wert des :start2-Arguments
  1639. # erhöht STACK um 6
  1640.   local uintL test_2_stringsym_limits (uintB** charptr1_, uintL* len1_, uintB** charptr2_, uintL* len2_);
  1641.   local uintL test_2_stringsym_limits(charptr1_,len1_,charptr2_,len2_)
  1642.     var reg4 uintB** charptr1_;
  1643.     var reg5 uintL* len1_;
  1644.     var reg4 uintB** charptr2_;
  1645.     var reg5 uintL* len2_;
  1646.     { var uintL len1;
  1647.       var uintL len2;
  1648.       { # String/Symbol-Argument1 überprüfen:
  1649.         var reg1 object string1 = test_stringsymchar_arg(STACK_5);
  1650.         pushSTACK(string1); # string1 retten
  1651.         # String/Symbol-Argument2 überprüfen:
  1652.        {var reg2 object string2 = test_stringsymchar_arg(STACK_(4+1));
  1653.         *charptr2_ = unpack_string(string2,&len2);
  1654.         # Nun ist len2 die Länge (<2^oint_data_len) von string2, und ab charptr2 kommen die Zeichen.
  1655.         string1 = popSTACK(); # string1 zurück
  1656.         charptr1_[1] = *charptr1_ = unpack_string(string1,&len1);
  1657.         # Nun ist len1 die Länge (<2^oint_data_len) von string1, und ab charptr1 kommen die Zeichen.
  1658.       }}
  1659.       # :START1 und :END1 überprüfen:
  1660.       { var reg3 uintL start1;
  1661.         var reg2 uintL end1;
  1662.         # :START1-Argument überprüfen:
  1663.           # start1 := Index STACK_3, Defaultwert 0, muß <=len1 sein:
  1664.           //: DEUTSCH ":START1-"
  1665.           //: ENGLISH ":start1-"
  1666.           //: FRANCAIS ":start1-"
  1667.           test_index(STACK_3,start1=,1,0,<=,len1,GETTEXT(":start1-"));
  1668.         # start1 ist jetzt der Wert des :START1-Arguments.
  1669.         # :END1-Argument überprüfen:
  1670.           # end1 := Index STACK_2, Defaultwert len1, muß <=len1 sein:
  1671.           //: DEUTSCH ":END1-"
  1672.           //: ENGLISH ":end1-"
  1673.           //: FRANCAIS ":end1-"
  1674.           test_index(STACK_2,end1=,2,len1,<=,len1,GETTEXT(":end1-"));
  1675.         # end1 ist jetzt der Wert des :END1-Arguments.
  1676.         # Vergleiche :START1 und :END1 Argumente:
  1677.         if (!(start1 <= end1))
  1678.           { pushSTACK(STACK_2); # :END1-Index
  1679.             pushSTACK(STACK_4); # :START1-Index
  1680.             pushSTACK(TheSubr(subr_self)->name);
  1681.             //: DEUTSCH "~: :START1-Index ~ darf den :END1-Index ~ nicht überschreiten."
  1682.             //: ENGLISH "~: :start1-index ~ must not be greater than :end1-index ~"
  1683.             //: FRANCAIS "~: L'index :START1 ~ ne doit pas être supérieur à l'index :END1 ~."
  1684.             fehler(error,GETTEXT("~: :start1-index ~ must not be greater than :end1-index ~"));
  1685.           }
  1686.         # Ergebnisse zu string1 herausgeben:
  1687.         *charptr1_ += start1; *len1_ = end1-start1;
  1688.       }
  1689.       # :START2 und :END2 überprüfen:
  1690.       { var reg3 uintL start2;
  1691.         var reg2 uintL end2;
  1692.         # :START2-Argument überprüfen:
  1693.           # start2 := Index STACK_1, Defaultwert 0, muß <=len2 sein:
  1694.           //: DEUTSCH ":START2-"
  1695.           //: ENGLISH ":start2-"
  1696.           //: FRANCAIS ":start2-"
  1697.           test_index(STACK_1,start2=,1,0,<=,len2,GETTEXT(":start2-"));
  1698.         # start2 ist jetzt der Wert des :START2-Arguments.
  1699.         # :END2-Argument überprüfen:
  1700.           # end2 := Index STACK_0, Defaultwert len2, muß <=len2 sein:
  1701.           //: DEUTSCH ":END2-"
  1702.           //: ENGLISH ":end2-"
  1703.           //: FRANCAIS ":end2-"
  1704.           test_index(STACK_0,end2=,2,len2,<=,len2,GETTEXT(":end2-"));
  1705.         # end2 ist jetzt der Wert des :END2-Arguments.
  1706.         # Vergleiche :START2 und :END2 Argumente:
  1707.         if (!(start2 <= end2))
  1708.           { pushSTACK(STACK_0); # :END2-Index
  1709.             pushSTACK(STACK_2); # :START2-Index
  1710.             pushSTACK(TheSubr(subr_self)->name);
  1711.             //: DEUTSCH "~: :START2-Index ~ darf den :END2-Index ~ nicht überschreiten."
  1712.             //: ENGLISH "~: :start2-index ~ must not be greater than :end2-index ~"
  1713.             //: FRANCAIS "~: L'index :START2 ~ ne doit pas être supérieur à l'index :END2 ~."
  1714.             fehler(error,GETTEXT("~: :start2-index ~ must not be greater than :end2-index ~"));
  1715.           }
  1716.         # Ergebnisse zu string2 herausgeben:
  1717.         *charptr2_ += start2; *len2_ = end2-start2;
  1718.         # Fertig.
  1719.         skipSTACK(6);
  1720.         return start2;
  1721.     } }
  1722.  
  1723. # UP: vergleicht zwei gleichlange Strings auf Gleichheit
  1724. # > charptr1: Ab hier kommen die angesprochenen Characters im String1
  1725. # > charptr2: Ab hier kommen die angesprochenen Characters im String2
  1726. # > len: Anzahl der angesprochenen Characters in String1 und in String2
  1727. # < ergebnis: TRUE falls gleich, FALSE sonst.
  1728.   local boolean string_eqcomp (uintB* charptr1, uintB* charptr2, uintL len);
  1729.   local boolean string_eqcomp(charptr1,charptr2,len)
  1730.     var reg1 uintB* charptr1;
  1731.     var reg2 uintB* charptr2;
  1732.     var reg3 uintL len;
  1733.     { dotimesL(len,len, { if (!(*charptr1++ == *charptr2++)) goto no; } );
  1734.       return TRUE;
  1735.       no: return FALSE;
  1736.     }
  1737.  
  1738. # UP: vergleicht zwei Strings
  1739. # > charptr1: Ab hier kommen die angesprochenen Characters im String1
  1740. # > len1: Anzahl der angesprochenen Characters im String1
  1741. # > charptr2: Ab hier kommen die angesprochenen Characters im String2
  1742. # > len2: Anzahl der angesprochenen Characters im String2
  1743. # < charptr1: Stelle des ersten Unterschieds im String1
  1744. # < ergebnis: 0 falls gleich,
  1745. #             -1 falls String1 echt vor String2 kommt,
  1746. #             +1 falls String1 echt nach String2 kommt.
  1747.   local signean string_comp (uintB** charptr1_, uintL len1, uintB* charptr2, uintL len2);
  1748.   local signean string_comp(charptr1_,len1,charptr2,len2)
  1749.     var reg4 uintB** charptr1_;
  1750.     var reg3 uintL len1;
  1751.     var reg2 uintB* charptr2;
  1752.     var reg3 uintL len2;
  1753.     { var reg2 uintB* charptr1 = *charptr1_;
  1754.       loop
  1755.         { # einer der Strings zu Ende ?
  1756.           if (len1==0) goto string1_end;
  1757.           if (len2==0) goto string2_end;
  1758.           # nächste Characters vergleichen:
  1759.           if (!(*charptr1++ == *charptr2++)) break;
  1760.           # beide Zähler erniedrigen:
  1761.           len1--; len2--;
  1762.         }
  1763.       # zwei verschiedene Characters gefunden
  1764.       *charptr1_ = --charptr1;
  1765.       if (*charptr1 < *--charptr2)
  1766.         return signean_minus; # String1 < String2
  1767.         else
  1768.         return signean_plus; # String1 > String2
  1769.       string1_end: # String1 zu Ende
  1770.         *charptr1_ = charptr1;
  1771.         if (len2==0)
  1772.           return signean_null; # String1 = String2
  1773.           else
  1774.           return signean_minus; # String1 ist echtes Anfangsstück von String2
  1775.       string2_end: # String2 zu Ende, String1 noch nicht
  1776.         *charptr1_ = charptr1;
  1777.         return signean_plus; # String2 ist echtes Anfangsstück von String1
  1778.     }
  1779.  
  1780. LISPFUN(string_gleich,2,0,norest,key,4,\
  1781.         (kw(start1),kw(end1),kw(start2),kw(end2)) )
  1782. # (STRING= string1 string2 :start1 :end1 :start2 :end2), CLTL S. 300
  1783.   { var uintB* charptr1[2];
  1784.     var uintL len1;
  1785.     var uintB* charptr2;
  1786.     var uintL len2;
  1787.     # Argumente überprüfen:
  1788.     test_2_stringsym_limits(&!charptr1,&len1,&charptr2,&len2);
  1789.     # vergleichen:
  1790.     value1 = (((len1==len2) && string_eqcomp(charptr1[0],charptr2,len1)) ? T : NIL);
  1791.     mv_count=1;
  1792.   }
  1793.  
  1794. LISPFUN(string_ungleich,2,0,norest,key,4,\
  1795.         (kw(start1),kw(end1),kw(start2),kw(end2)) )
  1796. # (STRING/= string1 string2 :start1 :end1 :start2 :end2), CLTL S. 301
  1797.   { var uintB* charptr1[2];
  1798.     var uintL len1;
  1799.     var uintB* charptr2;
  1800.     var uintL len2;
  1801.     # Argumente überprüfen:
  1802.     test_2_stringsym_limits(&!charptr1,&len1,&charptr2,&len2);
  1803.     # vergleichen:
  1804.     value1 = (string_comp(charptr1,len1,charptr2,len2)==0 ? NIL : fixnum(charptr1[0]-charptr1[1]));
  1805.     mv_count=1;
  1806.   }
  1807.  
  1808. LISPFUN(string_kleiner,2,0,norest,key,4,\
  1809.         (kw(start1),kw(end1),kw(start2),kw(end2)) )
  1810. # (STRING< string1 string2 :start1 :end1 :start2 :end2), CLTL S. 301
  1811.   { var uintB* charptr1[2];
  1812.     var uintL len1;
  1813.     var uintB* charptr2;
  1814.     var uintL len2;
  1815.     # Argumente überprüfen:
  1816.     test_2_stringsym_limits(&!charptr1,&len1,&charptr2,&len2);
  1817.     # vergleichen:
  1818.     value1 = (string_comp(charptr1,len1,charptr2,len2)<0 ? fixnum(charptr1[0]-charptr1[1]) : NIL);
  1819.     mv_count=1;
  1820.   }
  1821.  
  1822. LISPFUN(string_groesser,2,0,norest,key,4,\
  1823.         (kw(start1),kw(end1),kw(start2),kw(end2)) )
  1824. # (STRING> string1 string2 :start1 :end1 :start2 :end2), CLTL S. 301
  1825.   { var uintB* charptr1[2];
  1826.     var uintL len1;
  1827.     var uintB* charptr2;
  1828.     var uintL len2;
  1829.     # Argumente überprüfen:
  1830.     test_2_stringsym_limits(&!charptr1,&len1,&charptr2,&len2);
  1831.     # vergleichen:
  1832.     value1 = (string_comp(charptr1,len1,charptr2,len2)>0 ? fixnum(charptr1[0]-charptr1[1]) : NIL);
  1833.     mv_count=1;
  1834.   }
  1835.  
  1836. LISPFUN(string_klgleich,2,0,norest,key,4,\
  1837.         (kw(start1),kw(end1),kw(start2),kw(end2)) )
  1838. # (STRING<= string1 string2 :start1 :end1 :start2 :end2), CLTL S. 301
  1839.   { var uintB* charptr1[2];
  1840.     var uintL len1;
  1841.     var uintB* charptr2;
  1842.     var uintL len2;
  1843.     # Argumente überprüfen:
  1844.     test_2_stringsym_limits(&!charptr1,&len1,&charptr2,&len2);
  1845.     # vergleichen:
  1846.     value1 = (string_comp(charptr1,len1,charptr2,len2)<=0 ? fixnum(charptr1[0]-charptr1[1]) : NIL);
  1847.     mv_count=1;
  1848.   }
  1849.  
  1850. LISPFUN(string_grgleich,2,0,norest,key,4,\
  1851.         (kw(start1),kw(end1),kw(start2),kw(end2)) )
  1852. # (STRING>= string1 string2 :start1 :end1 :start2 :end2), CLTL S. 301
  1853.   { var uintB* charptr1[2];
  1854.     var uintL len1;
  1855.     var uintB* charptr2;
  1856.     var uintL len2;
  1857.     # Argumente überprüfen:
  1858.     test_2_stringsym_limits(&!charptr1,&len1,&charptr2,&len2);
  1859.     # vergleichen:
  1860.     value1 = (string_comp(charptr1,len1,charptr2,len2)>=0 ? fixnum(charptr1[0]-charptr1[1]) : NIL);
  1861.     mv_count=1;
  1862.   }
  1863.  
  1864. # UP: vergleicht zwei gleichlange Strings auf Gleichheit, case-insensitive
  1865. # > charptr1: Ab hier kommen die angesprochenen Characters im String1
  1866. # > charptr2: Ab hier kommen die angesprochenen Characters im String2
  1867. # > len: Anzahl der angesprochenen Characters in String1 und in String2
  1868. # < ergebnis: TRUE falls gleich, FALSE sonst.
  1869.   local boolean string_eqcomp_ci (uintB* charptr1, uintB* charptr2, uintL len);
  1870.   local boolean string_eqcomp_ci(charptr1,charptr2,len)
  1871.     var reg1 uintB* charptr1;
  1872.     var reg2 uintB* charptr2;
  1873.     var reg3 uintL len;
  1874.     { dotimesL(len,len,
  1875.         { if (!(up_case(*charptr1++) == up_case(*charptr2++))) goto no; }
  1876.         );
  1877.       return TRUE;
  1878.       no: return FALSE;
  1879.     }
  1880.  
  1881. # UP: vergleicht zwei Strings, case-insensitive
  1882. # > charptr1: Ab hier kommen die angesprochenen Characters im String1
  1883. # > len1: Anzahl der angesprochenen Characters im String1
  1884. # > charptr2: Ab hier kommen die angesprochenen Characters im String2
  1885. # > len2: Anzahl der angesprochenen Characters im String2
  1886. # < charptr1: Stelle des ersten Unterschieds im String1
  1887. # < ergebnis: 0 falls gleich,
  1888. #             -1 falls String1 echt vor String2 kommt,
  1889. #             +1 falls String1 echt nach String2 kommt.
  1890.   local signean string_comp_ci (uintB** charptr1_, uintL len1, uintB* charptr2, uintL len2);
  1891.   local signean string_comp_ci(charptr1_,len1,charptr2,len2)
  1892.     var reg4 uintB** charptr1_;
  1893.     var reg3 uintL len1;
  1894.     var reg2 uintB* charptr2;
  1895.     var reg3 uintL len2;
  1896.     { var reg2 uintB* charptr1 = *charptr1_;
  1897.       var reg1 uintB ch1;
  1898.       var reg1 uintB ch2;
  1899.       loop
  1900.         { # einer der Strings zu Ende ?
  1901.           if (len1==0) goto string1_end;
  1902.           if (len2==0) goto string2_end;
  1903.           # nächste Characters vergleichen:
  1904.           if (!((ch1 = up_case(*charptr1++)) == (ch2 = up_case(*charptr2++)))) break;
  1905.           # beide Zähler erniedrigen:
  1906.           len1--; len2--;
  1907.         }
  1908.       # zwei verschiedene Characters gefunden
  1909.       *charptr1_ = --charptr1;
  1910.       if (ch1 < ch2)
  1911.         return signean_minus; # String1 < String2
  1912.         else
  1913.         return signean_plus; # String1 > String2
  1914.       string1_end: # String1 zu Ende
  1915.         *charptr1_ = charptr1;
  1916.         if (len2==0)
  1917.           return signean_null; # String1 = String2
  1918.           else
  1919.           return signean_minus; # String1 ist echtes Anfangsstück von String2
  1920.       string2_end: # String2 zu Ende, String1 noch nicht
  1921.         *charptr1_ = charptr1;
  1922.         return signean_plus; # String2 ist echtes Anfangsstück von String1
  1923.     }
  1924.  
  1925. LISPFUN(string_equal,2,0,norest,key,4,\
  1926.         (kw(start1),kw(end1),kw(start2),kw(end2)) )
  1927. # (STRING-EQUAL string1 string2 :start1 :end1 :start2 :end2), CLTL S. 301
  1928.   { var uintB* charptr1[2];
  1929.     var uintL len1;
  1930.     var uintB* charptr2;
  1931.     var uintL len2;
  1932.     # Argumente überprüfen:
  1933.     test_2_stringsym_limits(&!charptr1,&len1,&charptr2,&len2);
  1934.     # vergleichen:
  1935.     value1 = (((len1==len2) && string_eqcomp_ci(charptr1[0],charptr2,len1)) ? T : NIL);
  1936.     mv_count=1;
  1937.   }
  1938.  
  1939. LISPFUN(string_not_equal,2,0,norest,key,4,\
  1940.         (kw(start1),kw(end1),kw(start2),kw(end2)) )
  1941. # (STRING-NOT-EQUAL string1 string2 :start1 :end1 :start2 :end2), CLTL S. 302
  1942.   { var uintB* charptr1[2];
  1943.     var uintL len1;
  1944.     var uintB* charptr2;
  1945.     var uintL len2;
  1946.     # Argumente überprüfen:
  1947.     test_2_stringsym_limits(&!charptr1,&len1,&charptr2,&len2);
  1948.     # vergleichen:
  1949.     value1 = (string_comp_ci(charptr1,len1,charptr2,len2)==0 ? NIL : fixnum(charptr1[0]-charptr1[1]));
  1950.     mv_count=1;
  1951.   }
  1952.  
  1953. LISPFUN(string_lessp,2,0,norest,key,4,\
  1954.         (kw(start1),kw(end1),kw(start2),kw(end2)) )
  1955. # (STRING-LESSP string1 string2 :start1 :end1 :start2 :end2), CLTL S. 302
  1956.   { var uintB* charptr1[2];
  1957.     var uintL len1;
  1958.     var uintB* charptr2;
  1959.     var uintL len2;
  1960.     # Argumente überprüfen:
  1961.     test_2_stringsym_limits(&!charptr1,&len1,&charptr2,&len2);
  1962.     # vergleichen:
  1963.     value1 = (string_comp_ci(charptr1,len1,charptr2,len2)<0 ? fixnum(charptr1[0]-charptr1[1]) : NIL);
  1964.     mv_count=1;
  1965.   }
  1966.  
  1967. LISPFUN(string_greaterp,2,0,norest,key,4,\
  1968.         (kw(start1),kw(end1),kw(start2),kw(end2)) )
  1969. # (STRING-GREATERP string1 string2 :start1 :end1 :start2 :end2), CLTL S. 302
  1970.   { var uintB* charptr1[2];
  1971.     var uintL len1;
  1972.     var uintB* charptr2;
  1973.     var uintL len2;
  1974.     # Argumente überprüfen:
  1975.     test_2_stringsym_limits(&!charptr1,&len1,&charptr2,&len2);
  1976.     # vergleichen:
  1977.     value1 = (string_comp_ci(charptr1,len1,charptr2,len2)>0 ? fixnum(charptr1[0]-charptr1[1]) : NIL);
  1978.     mv_count=1;
  1979.   }
  1980.  
  1981. LISPFUN(string_not_greaterp,2,0,norest,key,4,\
  1982.         (kw(start1),kw(end1),kw(start2),kw(end2)) )
  1983. # (STRING-NOT-GREATERP string1 string2 :start1 :end1 :start2 :end2), CLTL S. 302
  1984.   { var uintB* charptr1[2];
  1985.     var uintL len1;
  1986.     var uintB* charptr2;
  1987.     var uintL len2;
  1988.     # Argumente überprüfen:
  1989.     test_2_stringsym_limits(&!charptr1,&len1,&charptr2,&len2);
  1990.     # vergleichen:
  1991.     value1 = (string_comp_ci(charptr1,len1,charptr2,len2)<=0 ? fixnum(charptr1[0]-charptr1[1]) : NIL);
  1992.     mv_count=1;
  1993.   }
  1994.  
  1995. LISPFUN(string_not_lessp,2,0,norest,key,4,\
  1996.         (kw(start1),kw(end1),kw(start2),kw(end2)) )
  1997. # (STRING-NOT-LESSP string1 string2 :start1 :end1 :start2 :end2), CLTL S. 302
  1998.   { var uintB* charptr1[2];
  1999.     var uintL len1;
  2000.     var uintB* charptr2;
  2001.     var uintL len2;
  2002.     # Argumente überprüfen:
  2003.     test_2_stringsym_limits(&!charptr1,&len1,&charptr2,&len2);
  2004.     # vergleichen:
  2005.     value1 = (string_comp_ci(charptr1,len1,charptr2,len2)>=0 ? fixnum(charptr1[0]-charptr1[1]) : NIL);
  2006.     mv_count=1;
  2007.   }
  2008.  
  2009. # UP: sucht einen String String1 in einem anderen String String2
  2010. # > charptr1: Ab hier kommen die angesprochenen Characters im String1
  2011. # > len1: Anzahl der angesprochenen Characters im String1
  2012. # > charptr2: Ab hier kommen die angesprochenen Characters im String2
  2013. # > len2: Anzahl der angesprochenen Characters im String2
  2014. # > start2: Startposition im String2
  2015. # > eqcomp: Vergleichsfunktion, &string_eqcomp oder &string_eqcomp_ci
  2016. # < ergebnis: NIL falls nicht gefunden,
  2017. #             Position im String2 (als Fixnum) falls gefunden.
  2018.   # eqcomp_fun sei der Typ einer solchen Vergleichsfunktion:
  2019.   typedef boolean (*eqcomp_fun) (uintB* charptr1, uintB* charptr2, uintL len);
  2020.   local object string_search(uintB* charptr1, uintL len1, uintB* charptr2, uintL len2, uintL start2, eqcomp_fun eqcomp);
  2021.   local object string_search(charptr1,len1,charptr2,len2,start2,eqcomp)
  2022.     var reg3 uintB* charptr1;
  2023.     var reg5 uintL len1;
  2024.     var reg1 uintB* charptr2;
  2025.     var reg7 uintL len2;
  2026.     var reg6 uintL start2;
  2027.     var reg5 eqcomp_fun eqcomp;
  2028.     { var reg2 uintL count;
  2029.       if (len1>len2) goto notfound; # Nur bei len1<=len2 kann String1 in String2 vorkommen.
  2030.       # Schleife:
  2031.       # for i=0..len2-len1:
  2032.       #   vergleiche String1 mit den len1 Characters ab charptr2[i].
  2033.       # Dazu Schleife len2-len1+1 mal durchlaufen, charptr2 und start2 wachsen.
  2034.       dotimespL(count,len2-len1+1,
  2035.         { if ((*eqcomp)(charptr1,charptr2,len1)) goto found; # vergleichen
  2036.           charptr2++; # weiterrücken
  2037.           start2++; # und Position von charptr2 mitzählen
  2038.         });
  2039.       notfound: return NIL;
  2040.       found: return fixnum(start2);
  2041.     }
  2042.  
  2043. LISPFUN(search_string_gleich,2,0,norest,key,4,\
  2044.         (kw(start1),kw(end1),kw(start2),kw(end2)) )
  2045. # (SYS::SEARCH-STRING= string1 string2 [:start1] [:end1] [:start2] [:end2])
  2046. # = (search string1 string2 :test #'char= [:start1] [:end1] [:start2] [:end2])
  2047.   { var uintB* charptr1[2];
  2048.     var uintL len1;
  2049.     var uintB* charptr2;
  2050.     var uintL len2;
  2051.     # Argumente überprüfen:
  2052.     var uintL start2 =
  2053.       test_2_stringsym_limits(&!charptr1,&len1,&charptr2,&len2);
  2054.     # String1 in String2 suchen:
  2055.     value1 = string_search(charptr1[0],len1,charptr2,len2,start2,&string_eqcomp);
  2056.     mv_count=1;
  2057.   }
  2058.  
  2059. LISPFUN(search_string_equal,2,0,norest,key,4,\
  2060.         (kw(start1),kw(end1),kw(start2),kw(end2)) )
  2061. # (SYS::SEARCH-STRING-EQUAL string1 string2 [:start1] [:end1] [:start2] [:end2])
  2062. # = (search string1 string2 :test #'char-equal [:start1] [:end1] [:start2] [:end2])
  2063.   { var uintB* charptr1[2];
  2064.     var uintL len1;
  2065.     var uintB* charptr2;
  2066.     var uintL len2;
  2067.     # Argumente überprüfen:
  2068.     var uintL start2 =
  2069.       test_2_stringsym_limits(&!charptr1,&len1,&charptr2,&len2);
  2070.     # String1 in String2 suchen:
  2071.     value1 = string_search(charptr1[0],len1,charptr2,len2,start2,&string_eqcomp_ci);
  2072.     mv_count=1;
  2073.   }
  2074.  
  2075. LISPFUN(make_string,1,0,norest,key,1, (kw(initial_element)) )
  2076. # (MAKE-STRING size :initial-element), CLTL S. 302
  2077.   { var reg2 uintL size;
  2078.     # size überprüfen:
  2079.     if (!(mposfixnump(STACK_1))) # size muß Fixnum >= 0 sein
  2080.       { pushSTACK(STACK_1); # Wert für Slot DATUM von TYPE-ERROR
  2081.         pushSTACK(O(type_posfixnum)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  2082.         pushSTACK(STACK_(1+2)); pushSTACK(TheSubr(subr_self)->name);
  2083.         //: DEUTSCH "~: ~ ist als Stringlänge nicht geeignet, da kein Fixnum >= 0."
  2084.         //: ENGLISH "~: the string length ~ should be nonnegative fixnum"
  2085.         //: FRANCAIS "~: La longueur de chaîne ~ doit être de type FIXNUM positif ou zéro."
  2086.         fehler(type_error,GETTEXT("~: the string length ~ should be nonnegative fixnum"));
  2087.       }
  2088.     size = posfixnum_to_L(STACK_1);
  2089.    {var reg5 object new_string = allocate_string(size); # neuen String besorgen
  2090.     # evtl. mit initial-element füllen:
  2091.     var reg4 object initial_element = STACK_0;
  2092.     if (eq(initial_element,unbound))
  2093.       ; # nicht angegeben -> nichts zu tun
  2094.       else
  2095.       if (!(string_char_p(initial_element))) # sonst: muß ein String-Char sein
  2096.         { pushSTACK(initial_element); # Wert für Slot DATUM von TYPE-ERROR
  2097.           pushSTACK(S(string_char)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  2098.           pushSTACK(initial_element); pushSTACK(TheSubr(subr_self)->name);
  2099.           //: DEUTSCH "~: :INITIAL-ELEMENT ~ ist nicht vom Typ STRING-CHAR."
  2100.           //: ENGLISH "~: :initial-element ~ should be of type string-char"
  2101.           //: FRANCAIS "~: L'élément initial ~ n'est pas de type STRING-CHAR."
  2102.           fehler(type_error,GETTEXT("~: :initial-element ~ should be of type string-char"));
  2103.         }
  2104.         else
  2105.         { var reg3 uintB ch = char_code(initial_element);
  2106.           # String mit ch vollschreiben:
  2107.           if (!(size==0))
  2108.             { var reg1 uintB* charptr = &TheSstring(new_string)->data[0];
  2109.               dotimespL(size,size, { *charptr++ = ch; } );
  2110.         }   }
  2111.     value1 = new_string; mv_count=1; skipSTACK(2);
  2112.   }}
  2113.  
  2114. LISPFUNN(string_both_trim,3)
  2115. # (SYS::STRING-BOTH-TRIM character-bag-left character-bag-right string)
  2116. # Grundfunktion für
  2117. # STRING-TRIM, STRING-LEFT-TRIM, STRING-RIGHT-TRIM, CLTL S. 302
  2118. # Methode:
  2119. # (let ((l (length string)))
  2120. #   (do ((i 0 (1+ i)))
  2121. #       (nil)
  2122. #     (when (or (= i l)
  2123. #               (not (find (char string i) character-bag-left))
  2124. #           )
  2125. #       (do ((j l (1- j)))
  2126. #           (nil)
  2127. #         (when (or (= i j)
  2128. #                   (not (find (char string (1- j)) character-bag-right))
  2129. #               )
  2130. #           (return (if (and (= i 0) (= j l)) string (substring string i j)))
  2131. # ) ) ) ) )
  2132.   { var reg3 object string = test_stringsymchar_arg(popSTACK()); # Argument in String umwandeln
  2133.     pushSTACK(string); # und wieder in den Stack
  2134.     pushSTACK(fixnum(vector_length(string))); # Länge als Fixnum in den Stack
  2135.     pushSTACK(Fixnum_0); # i := 0
  2136.     # Stackaufbau: bag-left, bag-right, string, l, i
  2137.     loop
  2138.       { if (eq(STACK_0,STACK_1)) break; # bei i = l (beides Fixnums): Schleife fertig
  2139.         # (char string i) bestimmen:
  2140.         pushSTACK(STACK_2); pushSTACK(STACK_1); funcall(L(char),2);
  2141.         # (find (char ...) character-bag-left) bestimmen:
  2142.         pushSTACK(value1); pushSTACK(STACK_5); funcall(L(find),2);
  2143.         if (nullp(value1)) break; # char nicht in character-bag-left -> Schleife fertig
  2144.         STACK_0 = fixnum_inc(STACK_0,1); # i := (1+ i)
  2145.       }
  2146.     pushSTACK(STACK_1); # j := l
  2147.     # Stackaufbau: bag-left, bag-right, string, l, i, j
  2148.     loop
  2149.       { if (eq(STACK_0,STACK_1)) break; # bei j = i (beides Fixnums): Schleife fertig
  2150.         # (char string (1- j)) bestimmen:
  2151.         pushSTACK(STACK_3); pushSTACK(fixnum_inc(STACK_1,-1)); funcall(L(char),2);
  2152.         # (find (char ...) character-bag-right) bestimmen:
  2153.         pushSTACK(value1); pushSTACK(STACK_5); funcall(L(find),2);
  2154.         if (nullp(value1)) break; # char nicht in character-bag-right -> Schleife fertig
  2155.         STACK_0 = fixnum_inc(STACK_0,-1); # j := (1- j)
  2156.       }
  2157.     # Stackaufbau: bag-left, bag-right, string, l, i, j
  2158.     # Die Zeichen mit Index <i oder >=j des Strings wegwerfen:
  2159.     { var reg4 object j = popSTACK();
  2160.       var reg4 object i = popSTACK();
  2161.       var reg4 object l = popSTACK();
  2162.       string = popSTACK();
  2163.       skipSTACK(2);
  2164.       if (eq(i,Fixnum_0) && eq(j,l))
  2165.         { value1 = string; } # bei i=0 und j=l ist nichts zu tun, string als Wert
  2166.         else
  2167.         { # Teilstück der Indizes >=i, <j herauskopieren:
  2168.           # (substring string i j) als Wert
  2169.           pushSTACK(string); pushSTACK(i); pushSTACK(j); funcall(L(substring),3);
  2170.         }
  2171.       mv_count=1;
  2172.   } }
  2173.  
  2174. # UP: wandelt die Characters eines Stringstücks in Großbuchstaben
  2175. # nstring_upcase(charptr,len);
  2176. # > uintB* charptr: Ab hier kommen die angesprochenen Characters
  2177. # > uintL len: Anzahl der angesprochenen Characters
  2178.   global void nstring_upcase (uintB* charptr, uintL len);
  2179.   global void nstring_upcase(charptr,len)
  2180.     var reg1 uintB* charptr;
  2181.     var reg2 uintL len;
  2182.     { dotimesL(len,len, { *charptr = up_case(*charptr); charptr++; } ); }
  2183.  
  2184. # UP: wandelt einen String in Großbuchstaben
  2185. # string_upcase(string)
  2186. # > string: String
  2187. # < ergebnis: neuer Simple-String, in Großbuchstaben
  2188. # kann GC auslösen
  2189.   global object string_upcase (object string);
  2190.   global object string_upcase(string)
  2191.     var reg1 object string;
  2192.     { string = copy_string(string); # kopieren und dabei zum Simple-String machen
  2193.       nstring_upcase(&TheSstring(string)->data[0],TheSstring(string)->length); # umwandeln
  2194.       return string;
  2195.     }
  2196.  
  2197. LISPFUN(nstring_upcase,1,0,norest,key,2, (kw(start),kw(end)) )
  2198. # (NSTRING-UPCASE string :start :end), CLTL S. 304
  2199.   { var object string;
  2200.     var local uintL start; # unbenutzt
  2201.     var uintL len;
  2202.     var reg1 uintB* charptr = test_string_limits(&string,&start,&len);
  2203.     nstring_upcase(charptr,len);
  2204.     value1 = string; mv_count=1;
  2205.   }
  2206.  
  2207. LISPFUN(string_upcase,1,0,norest,key,2, (kw(start),kw(end)) )
  2208. # (STRING-UPCASE string :start :end), CLTL S. 303
  2209.   { var object string;
  2210.     var uintL len;
  2211.     var reg1 uintB* charptr = test_1_stringsym_limits(&string,&len);
  2212.     nstring_upcase(charptr,len);
  2213.     value1 = string; mv_count=1;
  2214.   }
  2215.  
  2216. # UP: wandelt die Characters eines Stringstücks in Kleinbuchstaben
  2217. # nstring_downcase(charptr,len);
  2218. # > uintB* charptr: Ab hier kommen die angesprochenen Characters
  2219. # > uintL len: Anzahl der angesprochenen Characters
  2220.   global void nstring_downcase (uintB* charptr, uintL len);
  2221.   global void nstring_downcase(charptr,len)
  2222.     var reg1 uintB* charptr;
  2223.     var reg2 uintL len;
  2224.     { dotimesL(len,len, { *charptr = down_case(*charptr); charptr++; } ); }
  2225.  
  2226. # UP: wandelt einen String in Kleinbuchstaben
  2227. # string_downcase(string)
  2228. # > string: String
  2229. # < ergebnis: neuer Simple-String, in Kleinbuchstaben
  2230. # kann GC auslösen
  2231.   global object string_downcase (object string);
  2232.   global object string_downcase(string)
  2233.     var reg1 object string;
  2234.     { string = copy_string(string); # kopieren und dabei zum Simple-String machen
  2235.       nstring_downcase(&TheSstring(string)->data[0],TheSstring(string)->length); # umwandeln
  2236.       return string;
  2237.     }
  2238.  
  2239. LISPFUN(nstring_downcase,1,0,norest,key,2, (kw(start),kw(end)) )
  2240. # (NSTRING-DOWNCASE string :start :end), CLTL S. 304
  2241.   { var object string;
  2242.     var local uintL start; # unbenutzt
  2243.     var uintL len;
  2244.     var reg1 uintB* charptr = test_string_limits(&string,&start,&len);
  2245.     nstring_downcase(charptr,len);
  2246.     value1 = string; mv_count=1;
  2247.   }
  2248.  
  2249. LISPFUN(string_downcase,1,0,norest,key,2, (kw(start),kw(end)) )
  2250. # (STRING-DOWNCASE string :start :end), CLTL S. 303
  2251.   { var object string;
  2252.     var uintL len;
  2253.     var reg1 uintB* charptr = test_1_stringsym_limits(&string,&len);
  2254.     nstring_downcase(charptr,len);
  2255.     value1 = string; mv_count=1;
  2256.   }
  2257.  
  2258. # UP: wandelt die Worte eines Stringstücks in solche, die
  2259. # mit Großbuchstaben anfangen und mit Kleinbuchstaben weitergehen.
  2260. # nstring_capitalize(charptr,len);
  2261. # > uintB* charptr: Ab hier kommen die angesprochenen Characters
  2262. # > uintL len: Anzahl der angesprochenen Characters
  2263.   global void nstring_capitalize (uintB* charptr, uintL len);
  2264.   # Methode:
  2265.   # Jeweils abwechselnd nach Wortanfang suchen (und nichts umwandeln)
  2266.   # bzw. nach Wortende suchen (und dabei umwandeln).
  2267.   global void nstring_capitalize(charptr,len)
  2268.     var reg1 uintB* charptr;
  2269.     var reg2 uintL len;
  2270.     { # Suche den nächsten Wortanfang:
  2271.       suche_wortanfang:
  2272.         until (len==0)
  2273.           { if (alphanumericp(*charptr)) goto wortanfang;
  2274.             charptr++; len--;
  2275.           }
  2276.         return; # len=0 -> String zu Ende
  2277.       # Wortanfang gefunden
  2278.       wortanfang:
  2279.         *charptr = up_case(*charptr); # Zeichen in Großbuchstaben umwandeln
  2280.         charptr++;
  2281.         # Suche das Wortende:
  2282.         until (--len==0)
  2283.           { # mitten im Wort
  2284.             if (!(alphanumericp(*charptr))) goto suche_wortanfang;
  2285.             *charptr = down_case(*charptr); # Zeichen in Kleinbuchstaben umwandeln
  2286.             charptr++;
  2287.           }
  2288.         return; # len=0 -> String zu Ende
  2289.     }
  2290.  
  2291. LISPFUN(nstring_capitalize,1,0,norest,key,2, (kw(start),kw(end)) )
  2292. # (NSTRING-CAPITALIZE string :start :end), CLTL S. 304
  2293.   { var object string;
  2294.     var local uintL start; # unbenutzt
  2295.     var uintL len;
  2296.     var reg1 uintB* charptr = test_string_limits(&string,&start,&len);
  2297.     nstring_capitalize(charptr,len);
  2298.     value1 = string; mv_count=1;
  2299.   }
  2300.  
  2301. LISPFUN(string_capitalize,1,0,norest,key,2, (kw(start),kw(end)) )
  2302. # (STRING-CAPITALIZE string :start :end), CLTL S. 303
  2303.   { var object string;
  2304.     var uintL len;
  2305.     var reg1 uintB* charptr = test_1_stringsym_limits(&string,&len);
  2306.     nstring_capitalize(charptr,len);
  2307.     value1 = string; mv_count=1;
  2308.   }
  2309.  
  2310. LISPFUNN(string,1) # (STRING object), CLTL S. 304
  2311.   { value1 = test_stringsymchar_arg(popSTACK()); mv_count=1; }
  2312.  
  2313. LISPFUNN(name_char,1) # (NAME-CHAR name), CLTL S. 243
  2314.   { # Argument in einen String umwandeln, Character mit diesem Namen suchen:
  2315.     value1 = name_char(test_stringsymchar_arg(popSTACK()));
  2316.     mv_count=1;
  2317.   }
  2318.  
  2319. LISPFUN(substring,2,1,norest,nokey,0,NIL)
  2320. # (SUBSTRING string start [end]) wie SUBSEQ, aber nur für Strings
  2321.   { var reg4 object string;
  2322.     var reg3 uintL len;
  2323.     var reg1 uintL start;
  2324.     var reg2 uintL end;
  2325.     # String/Symbol-Argument überprüfen:
  2326.     string = test_stringsymchar_arg(STACK_2);
  2327.     len = vector_length(string);
  2328.     # Nun ist len die Länge (<2^oint_data_len).
  2329.     # :START-Argument überprüfen:
  2330.       # start := Index STACK_1, Defaultwert 0, muß <=len sein:
  2331.       //: DEUTSCH ":START-"
  2332.       //: ENGLISH ":start-"
  2333.       //: FRANCAIS ":start-"
  2334.       test_index(STACK_1,start=,1,0,<=,len,GETTEXT(":start-"));
  2335.     # start ist jetzt der Wert des :START-Arguments.
  2336.     # :END-Argument überprüfen:
  2337.       # end := Index STACK_0, Defaultwert len, muß <=len sein:
  2338.       //: DEUTSCH ":END-"
  2339.       //: ENGLISH ":end-"
  2340.       //: FRANCAIS ":end-"
  2341.       test_index(STACK_0,end=,2,len,<=,len,GETTEXT(":end-"));
  2342.     # end ist jetzt der Wert des :END-Arguments.
  2343.     # Vergleiche :START und :END Argumente:
  2344.     if (!(start <= end))
  2345.       { pushSTACK(STACK_0); # :END-Index
  2346.         pushSTACK(STACK_2); # :START-Index
  2347.         pushSTACK(TheSubr(subr_self)->name);
  2348.         //: DEUTSCH "~: :START-Index ~ darf den :END-Index ~ nicht überschreiten."
  2349.         //: ENGLISH "~: :start-index ~ must not be greater than :end-index ~"
  2350.         //: FRANCAIS "~: L'index :START ~ ne doit pas être supérieur à l'index :END ~."
  2351.         fehler(error,GETTEXT("~: :start-index ~ must not be greater than :end-index ~"));
  2352.       }
  2353.     skipSTACK(3);
  2354.     # Teilstring herausziehen:
  2355.     pushSTACK(string); # alten String retten
  2356.    {var reg2 uintL count = end-start; # Anzahl der zu kopierenden Characters
  2357.     var reg5 object new_string = allocate_string(count); # neuer String
  2358.     string = popSTACK(); # alter String
  2359.     {var uintL len; # nochmals die Länge des alten Strings
  2360.      var uintB* charptr1 = unpack_string(string,&len) + start;
  2361.      var uintB* charptr2 = &TheSstring(new_string)->data[0];
  2362.      dotimesL(count,count, { *charptr2++ = *charptr1++; } );
  2363.     }
  2364.     value1 = new_string; mv_count=1;
  2365.   }}
  2366.  
  2367. # UP: bildet einen aus mehreren Strings zusammengehängten String.
  2368. # string_concat(argcount)
  2369. # > uintC argcount: Anzahl der Argumente
  2370. # > auf dem STACK: die Argumente (sollten Strings sein)
  2371. # > subr_self: Aufrufer (ein SUBR) (unnötig, falls alle Argumente Strings sind)
  2372. # < ergebnis: Gesamtstring, neu erzeugt
  2373. # < STACK: aufgeräumt
  2374. # kann GC auslösen
  2375.   global object string_concat (uintC argcount);
  2376.   global object string_concat(argcount)
  2377.     var reg8 uintC argcount;
  2378.     { var reg9 object* args_pointer = (args_end_pointer STACKop argcount);
  2379.       # args_pointer = Pointer über die Argumente
  2380.       # Überprüfe, ob es alles Strings sind, und addiere die Längen:
  2381.       var reg9 uintL total_length = 0;
  2382.       { var reg2 object* argptr = args_pointer;
  2383.         var reg3 uintC count;
  2384.         dotimesC(count,argcount,
  2385.           { var reg1 object arg = NEXT(argptr); # nächstes Argument
  2386.             if (!(stringp(arg))) fehler_string(arg);
  2387.             total_length += vector_length(arg);
  2388.           });
  2389.       }
  2390.       # total_length ist jetzt die Gesamtlänge.
  2391.       { var reg6 object new_string = allocate_string(total_length); # neuer String
  2392.         var reg1 uintB* charptr2 = &TheSstring(new_string)->data[0];
  2393.         var reg5 object* argptr = args_pointer;
  2394.         dotimesC(argcount,argcount,
  2395.           { var reg4 object arg = NEXT(argptr); # nächster Argument-String
  2396.             var uintL len; # dessen Länge
  2397.             var reg2 uintB* charptr1 = unpack_string(arg,&len);
  2398.             var reg3 uintL count;
  2399.             # Kopiere len Characters von charptr1 nach charptr2:
  2400.             dotimesL(count,len, { *charptr2++ = *charptr1++; } );
  2401.           });
  2402.         set_args_end_pointer(args_pointer); # STACK aufräumen
  2403.         return new_string;
  2404.     } }
  2405.  
  2406. LISPFUN(string_concat,0,0,rest,nokey,0,NIL)
  2407. # (STRING-CONCAT {string})
  2408. # bildet einen aus den Argumenten zusammengehängten String
  2409.   { value1 = string_concat(argcount); mv_count=1; }
  2410.  
  2411.