diff options
| author | Richard M. Stallman | 1990-12-31 04:18:02 +0000 |
|---|---|---|
| committer | Richard M. Stallman | 1990-12-31 04:18:02 +0000 |
| commit | 14d55bce6e2bcc97b24307e45d2f5b61780471fe (patch) | |
| tree | 559ec62bbc56d0be38357314b8567dc5f4bb5116 /src | |
| parent | 1f924f9953d39e0a8bf9924ccef0b0411a756572 (diff) | |
| download | emacs-14d55bce6e2bcc97b24307e45d2f5b61780471fe.tar.gz emacs-14d55bce6e2bcc97b24307e45d2f5b61780471fe.zip | |
Initial revision
Diffstat (limited to 'src')
| -rw-r--r-- | src/dired.c | 478 | ||||
| -rw-r--r-- | src/mocklisp.c | 242 |
2 files changed, 720 insertions, 0 deletions
diff --git a/src/dired.c b/src/dired.c new file mode 100644 index 00000000000..feb68ed0506 --- /dev/null +++ b/src/dired.c | |||
| @@ -0,0 +1,478 @@ | |||
| 1 | /* Lisp functions for making directory listings. | ||
| 2 | Copyright (C) 1985, 1986 Free Software Foundation, Inc. | ||
| 3 | |||
| 4 | This file is part of GNU Emacs. | ||
| 5 | |||
| 6 | GNU Emacs is free software; you can redistribute it and/or modify | ||
| 7 | it under the terms of the GNU General Public License as published by | ||
| 8 | the Free Software Foundation; either version 1, or (at your option) | ||
| 9 | any later version. | ||
| 10 | |||
| 11 | GNU Emacs is distributed in the hope that it will be useful, | ||
| 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | GNU General Public License for more details. | ||
| 15 | |||
| 16 | You should have received a copy of the GNU General Public License | ||
| 17 | along with GNU Emacs; see the file COPYING. If not, write to | ||
| 18 | the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ | ||
| 19 | |||
| 20 | |||
| 21 | #include <stdio.h> | ||
| 22 | #include <sys/types.h> | ||
| 23 | #include <sys/stat.h> | ||
| 24 | |||
| 25 | #include "config.h" | ||
| 26 | |||
| 27 | #ifdef SYSV_SYSTEM_DIR | ||
| 28 | |||
| 29 | #include <dirent.h> | ||
| 30 | #define DIRENTRY struct dirent | ||
| 31 | #define NAMLEN(p) strlen (p->d_name) | ||
| 32 | |||
| 33 | #else | ||
| 34 | |||
| 35 | #ifdef NONSYSTEM_DIR_LIBRARY | ||
| 36 | #include "ndir.h" | ||
| 37 | #else /* not NONSYSTEM_DIR_LIBRARY */ | ||
| 38 | #include <sys/dir.h> | ||
| 39 | #endif /* not NONSYSTEM_DIR_LIBRARY */ | ||
| 40 | |||
| 41 | #define DIRENTRY struct direct | ||
| 42 | #define NAMLEN(p) p->d_namlen | ||
| 43 | |||
| 44 | extern DIR *opendir (); | ||
| 45 | extern struct direct *readdir (); | ||
| 46 | |||
| 47 | #endif | ||
| 48 | |||
| 49 | #undef NULL | ||
| 50 | |||
| 51 | #include "lisp.h" | ||
| 52 | #include "buffer.h" | ||
| 53 | #include "commands.h" | ||
| 54 | |||
| 55 | #include "regex.h" | ||
| 56 | #include "search.h" | ||
| 57 | |||
| 58 | #define min(a, b) ((a) < (b) ? (a) : (b)) | ||
| 59 | |||
| 60 | /* if system does not have symbolic links, it does not have lstat. | ||
| 61 | In that case, use ordinary stat instead. */ | ||
| 62 | |||
| 63 | #ifndef S_IFLNK | ||
| 64 | #define lstat stat | ||
| 65 | #endif | ||
| 66 | |||
| 67 | Lisp_Object Vcompletion_ignored_extensions; | ||
| 68 | |||
| 69 | Lisp_Object Qcompletion_ignore_case; | ||
| 70 | |||
| 71 | DEFUN ("directory-files", Fdirectory_files, Sdirectory_files, 1, 4, 0, | ||
| 72 | "Return a list of names of files in DIRECTORY.\n\ | ||
| 73 | There are three optional arguments:\n\ | ||
| 74 | If FULL is non-nil, absolute pathnames of the files are returned.\n\ | ||
| 75 | If MATCH is non-nil, only pathnames containing that regexp are returned.\n\ | ||
| 76 | If NOSORT is non-nil, the list is not sorted--its order is unpredictable.\n\ | ||
| 77 | NOSORT is useful if you plan to sort the result yourself.") | ||
| 78 | (dirname, full, match, nosort) | ||
| 79 | Lisp_Object dirname, full, match, nosort; | ||
| 80 | { | ||
| 81 | DIR *d; | ||
| 82 | int length; | ||
| 83 | Lisp_Object list, name; | ||
| 84 | |||
| 85 | if (!NULL (match)) | ||
| 86 | { | ||
| 87 | CHECK_STRING (match, 3); | ||
| 88 | /* Compile it now so we don't get an error after opendir */ | ||
| 89 | #ifdef VMS | ||
| 90 | compile_pattern (match, &searchbuf, | ||
| 91 | buffer_defaults.downcase_table->contents); | ||
| 92 | #else | ||
| 93 | compile_pattern (match, &searchbuf, 0); | ||
| 94 | #endif | ||
| 95 | } | ||
| 96 | |||
| 97 | dirname = Fexpand_file_name (dirname, Qnil); | ||
| 98 | if (!(d = opendir (XSTRING (Fdirectory_file_name (dirname))->data))) | ||
| 99 | report_file_error ("Opening directory", Fcons (dirname, Qnil)); | ||
| 100 | |||
| 101 | list = Qnil; | ||
| 102 | length = XSTRING (dirname)->size; | ||
| 103 | |||
| 104 | /* Loop reading blocks */ | ||
| 105 | while (1) | ||
| 106 | { | ||
| 107 | DIRENTRY *dp = readdir (d); | ||
| 108 | int len; | ||
| 109 | |||
| 110 | if (!dp) break; | ||
| 111 | len = NAMLEN (dp); | ||
| 112 | if (dp->d_ino) | ||
| 113 | { | ||
| 114 | if (NULL (match) | ||
| 115 | || (0 <= re_search (&searchbuf, dp->d_name, len, 0, len, 0))) | ||
| 116 | { | ||
| 117 | if (!NULL (full)) | ||
| 118 | { | ||
| 119 | int index = XSTRING (dirname)->size; | ||
| 120 | int total = len + index; | ||
| 121 | #ifndef VMS | ||
| 122 | if (length == 0 | ||
| 123 | || XSTRING (dirname)->data[length - 1] != '/') | ||
| 124 | total++; | ||
| 125 | #endif /* VMS */ | ||
| 126 | |||
| 127 | name = make_uninit_string (total); | ||
| 128 | bcopy (XSTRING (dirname)->data, XSTRING (name)->data, | ||
| 129 | index); | ||
| 130 | #ifndef VMS | ||
| 131 | if (length == 0 | ||
| 132 | || XSTRING (dirname)->data[length - 1] != '/') | ||
| 133 | XSTRING (name)->data[index++] = '/'; | ||
| 134 | #endif /* VMS */ | ||
| 135 | bcopy (dp->d_name, XSTRING (name)->data + index, len); | ||
| 136 | } | ||
| 137 | else | ||
| 138 | name = make_string (dp->d_name, len); | ||
| 139 | list = Fcons (name, list); | ||
| 140 | } | ||
| 141 | } | ||
| 142 | } | ||
| 143 | closedir (d); | ||
| 144 | if (!NULL (nosort)) | ||
| 145 | return list; | ||
| 146 | return Fsort (Fnreverse (list), Qstring_lessp); | ||
| 147 | } | ||
| 148 | |||
| 149 | Lisp_Object file_name_completion (); | ||
| 150 | |||
| 151 | DEFUN ("file-name-completion", Ffile_name_completion, Sfile_name_completion, | ||
| 152 | 2, 2, 0, | ||
| 153 | "Complete file name FILE in directory DIR.\n\ | ||
| 154 | Returns the longest string\n\ | ||
| 155 | common to all filenames in DIR that start with FILE.\n\ | ||
| 156 | If there is only one and FILE matches it exactly, returns t.\n\ | ||
| 157 | Returns nil if DIR contains no name starting with FILE.") | ||
| 158 | (file, dirname) | ||
| 159 | Lisp_Object file, dirname; | ||
| 160 | { | ||
| 161 | /* Don't waste time trying to complete a null string. | ||
| 162 | Besides, this case happens when user is being asked for | ||
| 163 | a directory name and has supplied one ending in a /. | ||
| 164 | We would not want to add anything in that case | ||
| 165 | even if there are some unique characters in that directory. */ | ||
| 166 | if (XTYPE (file) == Lisp_String && XSTRING (file)->size == 0) | ||
| 167 | return file; | ||
| 168 | return file_name_completion (file, dirname, 0, 0); | ||
| 169 | } | ||
| 170 | |||
| 171 | DEFUN ("file-name-all-completions", Ffile_name_all_completions, | ||
| 172 | Sfile_name_all_completions, 2, 2, 0, | ||
| 173 | "Return a list of all completions of file name FILE in directory DIR.\n\ | ||
| 174 | These are all file names in directory DIR which begin with FILE.") | ||
| 175 | (file, dirname) | ||
| 176 | Lisp_Object file, dirname; | ||
| 177 | { | ||
| 178 | return file_name_completion (file, dirname, 1, 0); | ||
| 179 | } | ||
| 180 | |||
| 181 | #ifdef VMS | ||
| 182 | |||
| 183 | DEFUN ("file-name-all-versions", Ffile_name_all_versions, | ||
| 184 | Sfile_name_all_versions, 2, 2, 0, | ||
| 185 | "Return a list of all versions of file name FILE in directory DIR.") | ||
| 186 | (file, dirname) | ||
| 187 | Lisp_Object file, dirname; | ||
| 188 | { | ||
| 189 | return file_name_completion (file, dirname, 1, 1); | ||
| 190 | } | ||
| 191 | |||
| 192 | #endif /* VMS */ | ||
| 193 | |||
| 194 | Lisp_Object | ||
| 195 | file_name_completion (file, dirname, all_flag, ver_flag) | ||
| 196 | Lisp_Object file, dirname; | ||
| 197 | int all_flag, ver_flag; | ||
| 198 | { | ||
| 199 | DIR *d; | ||
| 200 | DIRENTRY *dp; | ||
| 201 | int bestmatchsize, skip; | ||
| 202 | register int compare, matchsize; | ||
| 203 | unsigned char *p1, *p2; | ||
| 204 | int matchcount = 0; | ||
| 205 | Lisp_Object bestmatch, tem, elt, name; | ||
| 206 | struct stat st; | ||
| 207 | int directoryp; | ||
| 208 | int passcount; | ||
| 209 | int count = specpdl_ptr - specpdl; | ||
| 210 | #ifdef VMS | ||
| 211 | extern DIRENTRY * readdirver (); | ||
| 212 | |||
| 213 | DIRENTRY *((* readfunc) ()); | ||
| 214 | |||
| 215 | /* Filename completion on VMS ignores case, since VMS filesys does. */ | ||
| 216 | specbind (Qcompletion_ignore_case, Qt); | ||
| 217 | |||
| 218 | readfunc = readdir; | ||
| 219 | if (ver_flag) | ||
| 220 | readfunc = readdirver; | ||
| 221 | file = Fupcase (file); | ||
| 222 | #else /* not VMS */ | ||
| 223 | CHECK_STRING (file, 0); | ||
| 224 | #endif /* not VMS */ | ||
| 225 | |||
| 226 | dirname = Fexpand_file_name (dirname, Qnil); | ||
| 227 | bestmatch = Qnil; | ||
| 228 | |||
| 229 | /* With passcount = 0, ignore files that end in an ignored extension. | ||
| 230 | If nothing found then try again with passcount = 1, don't ignore them. | ||
| 231 | If looking for all completions, start with passcount = 1, | ||
| 232 | so always take even the ignored ones. | ||
| 233 | |||
| 234 | ** It would not actually be helpful to the user to ignore any possible | ||
| 235 | completions when making a list of them.** */ | ||
| 236 | |||
| 237 | for (passcount = !!all_flag; NULL (bestmatch) && passcount < 2; passcount++) | ||
| 238 | { | ||
| 239 | if (!(d = opendir (XSTRING (Fdirectory_file_name (dirname))->data))) | ||
| 240 | report_file_error ("Opening directory", Fcons (dirname, Qnil)); | ||
| 241 | |||
| 242 | /* Loop reading blocks */ | ||
| 243 | /* (att3b compiler bug requires do a null comparison this way) */ | ||
| 244 | while (1) | ||
| 245 | { | ||
| 246 | DIRENTRY *dp; | ||
| 247 | int len; | ||
| 248 | |||
| 249 | #ifdef VMS | ||
| 250 | dp = (*readfunc) (d); | ||
| 251 | #else | ||
| 252 | dp = readdir (d); | ||
| 253 | #endif | ||
| 254 | if (!dp) break; | ||
| 255 | |||
| 256 | len = NAMLEN (dp); | ||
| 257 | |||
| 258 | if (!NULL (Vquit_flag) && NULL (Vinhibit_quit)) | ||
| 259 | goto quit; | ||
| 260 | if (!dp->d_ino | ||
| 261 | || len < XSTRING (file)->size | ||
| 262 | || 0 <= scmp (dp->d_name, XSTRING (file)->data, | ||
| 263 | XSTRING (file)->size)) | ||
| 264 | continue; | ||
| 265 | |||
| 266 | if (file_name_completion_stat (dirname, dp, &st) < 0) | ||
| 267 | continue; | ||
| 268 | |||
| 269 | directoryp = ((st.st_mode & S_IFMT) == S_IFDIR); | ||
| 270 | tem = Qnil; | ||
| 271 | if (!directoryp) | ||
| 272 | { | ||
| 273 | /* Compare extensions-to-be-ignored against end of this file name */ | ||
| 274 | /* if name is not an exact match against specified string */ | ||
| 275 | if (!passcount && len > XSTRING (file)->size) | ||
| 276 | /* and exit this for loop if a match is found */ | ||
| 277 | for (tem = Vcompletion_ignored_extensions; | ||
| 278 | CONSP (tem); tem = XCONS (tem)->cdr) | ||
| 279 | { | ||
| 280 | elt = XCONS (tem)->car; | ||
| 281 | if (XTYPE (elt) != Lisp_String) continue; | ||
| 282 | skip = len - XSTRING (elt)->size; | ||
| 283 | if (skip < 0) continue; | ||
| 284 | |||
| 285 | if (0 <= scmp (dp->d_name + skip, | ||
| 286 | XSTRING (elt)->data, | ||
| 287 | XSTRING (elt)->size)) | ||
| 288 | continue; | ||
| 289 | break; | ||
| 290 | } | ||
| 291 | } | ||
| 292 | |||
| 293 | /* Unless an ignored-extensions match was found, | ||
| 294 | process this name as a completion */ | ||
| 295 | if (passcount || !CONSP (tem)) | ||
| 296 | { | ||
| 297 | /* Update computation of how much all possible completions match */ | ||
| 298 | |||
| 299 | matchcount++; | ||
| 300 | |||
| 301 | if (all_flag || NULL (bestmatch)) | ||
| 302 | { | ||
| 303 | /* This is a possible completion */ | ||
| 304 | if (directoryp) | ||
| 305 | { | ||
| 306 | /* This completion is a directory; make it end with '/' */ | ||
| 307 | name = Ffile_name_as_directory (make_string (dp->d_name, len)); | ||
| 308 | } | ||
| 309 | else | ||
| 310 | name = make_string (dp->d_name, len); | ||
| 311 | if (all_flag) | ||
| 312 | { | ||
| 313 | bestmatch = Fcons (name, bestmatch); | ||
| 314 | } | ||
| 315 | else | ||
| 316 | { | ||
| 317 | bestmatch = name; | ||
| 318 | bestmatchsize = XSTRING (name)->size; | ||
| 319 | } | ||
| 320 | } | ||
| 321 | else | ||
| 322 | { | ||
| 323 | compare = min (bestmatchsize, len); | ||
| 324 | p1 = XSTRING (bestmatch)->data; | ||
| 325 | p2 = (unsigned char *) dp->d_name; | ||
| 326 | matchsize = scmp(p1, p2, compare); | ||
| 327 | if (matchsize < 0) | ||
| 328 | matchsize = compare; | ||
| 329 | /* If this dirname all matches, | ||
| 330 | see if implicit following slash does too. */ | ||
| 331 | if (directoryp | ||
| 332 | && compare == matchsize | ||
| 333 | && bestmatchsize > matchsize | ||
| 334 | && p1[matchsize] == '/') | ||
| 335 | matchsize++; | ||
| 336 | bestmatchsize = min (matchsize, bestmatchsize); | ||
| 337 | } | ||
| 338 | } | ||
| 339 | } | ||
| 340 | closedir (d); | ||
| 341 | } | ||
| 342 | |||
| 343 | unbind_to (count, Qnil); | ||
| 344 | |||
| 345 | if (all_flag || NULL (bestmatch)) | ||
| 346 | return bestmatch; | ||
| 347 | if (matchcount == 1 && bestmatchsize == XSTRING (file)->size) | ||
| 348 | return Qt; | ||
| 349 | return Fsubstring (bestmatch, make_number (0), make_number (bestmatchsize)); | ||
| 350 | quit: | ||
| 351 | if (d) closedir (d); | ||
| 352 | Vquit_flag = Qnil; | ||
| 353 | return Fsignal (Qquit, Qnil); | ||
| 354 | } | ||
| 355 | |||
| 356 | file_name_completion_stat (dirname, dp, st_addr) | ||
| 357 | Lisp_Object dirname; | ||
| 358 | DIRENTRY *dp; | ||
| 359 | struct stat *st_addr; | ||
| 360 | { | ||
| 361 | int len = NAMLEN (dp); | ||
| 362 | int pos = XSTRING (dirname)->size; | ||
| 363 | char *fullname = (char *) alloca (len + pos + 2); | ||
| 364 | |||
| 365 | bcopy (XSTRING (dirname)->data, fullname, pos); | ||
| 366 | #ifndef VMS | ||
| 367 | if (fullname[pos - 1] != '/') | ||
| 368 | fullname[pos++] = '/'; | ||
| 369 | #endif | ||
| 370 | |||
| 371 | bcopy (dp->d_name, fullname + pos, len); | ||
| 372 | fullname[pos + len] = 0; | ||
| 373 | |||
| 374 | return stat (fullname, st_addr); | ||
| 375 | } | ||
| 376 | |||
| 377 | Lisp_Object | ||
| 378 | make_time (time) | ||
| 379 | int time; | ||
| 380 | { | ||
| 381 | return Fcons (make_number (time >> 16), | ||
| 382 | Fcons (make_number (time & 0177777), Qnil)); | ||
| 383 | } | ||
| 384 | |||
| 385 | DEFUN ("file-attributes", Ffile_attributes, Sfile_attributes, 1, 1, 0, | ||
| 386 | "Return a list of attributes of file FILENAME.\n\ | ||
| 387 | Value is nil if specified file cannot be opened.\n\ | ||
| 388 | Otherwise, list elements are:\n\ | ||
| 389 | 0. t for directory, string (name linked to) for symbolic link, or nil.\n\ | ||
| 390 | 1. Number of links to file.\n\ | ||
| 391 | 2. File uid.\n\ | ||
| 392 | 3. File gid.\n\ | ||
| 393 | 4. Last access time, as a list of two integers.\n\ | ||
| 394 | First integer has high-order 16 bits of time, second has low 16 bits.\n\ | ||
| 395 | 5. Last modification time, likewise.\n\ | ||
| 396 | 6. Last status change time, likewise.\n\ | ||
| 397 | 7. Size in bytes.\n\ | ||
| 398 | 8. File modes, as a string of ten letters or dashes as in ls -l.\n\ | ||
| 399 | 9. t iff file's gid would change if file were deleted and recreated.\n\ | ||
| 400 | 10. inode number.\n\ | ||
| 401 | 11. Device number.\n\ | ||
| 402 | \n\ | ||
| 403 | If file does not exists, returns nil.") | ||
| 404 | (filename) | ||
| 405 | Lisp_Object filename; | ||
| 406 | { | ||
| 407 | Lisp_Object values[12]; | ||
| 408 | Lisp_Object dirname; | ||
| 409 | struct stat s; | ||
| 410 | struct stat sdir; | ||
| 411 | char modes[10]; | ||
| 412 | |||
| 413 | filename = Fexpand_file_name (filename, Qnil); | ||
| 414 | if (lstat (XSTRING (filename)->data, &s) < 0) | ||
| 415 | return Qnil; | ||
| 416 | |||
| 417 | switch (s.st_mode & S_IFMT) | ||
| 418 | { | ||
| 419 | default: | ||
| 420 | values[0] = Qnil; break; | ||
| 421 | case S_IFDIR: | ||
| 422 | values[0] = Qt; break; | ||
| 423 | #ifdef S_IFLNK | ||
| 424 | case S_IFLNK: | ||
| 425 | values[0] = Ffile_symlink_p (filename); break; | ||
| 426 | #endif | ||
| 427 | } | ||
| 428 | values[1] = make_number (s.st_nlink); | ||
| 429 | values[2] = make_number (s.st_uid); | ||
| 430 | values[3] = make_number (s.st_gid); | ||
| 431 | values[4] = make_time (s.st_atime); | ||
| 432 | values[5] = make_time (s.st_mtime); | ||
| 433 | values[6] = make_time (s.st_ctime); | ||
| 434 | /* perhaps we should set this to most-positive-fixnum if it is too large? */ | ||
| 435 | values[7] = make_number (s.st_size); | ||
| 436 | filemodestring (&s, modes); | ||
| 437 | values[8] = make_string (modes, 10); | ||
| 438 | #ifdef BSD4_3 /* Gross kludge to avoid lack of "#if defined(...)" in VMS */ | ||
| 439 | #define BSD4_2 /* A new meaning to the term `backwards compatability' */ | ||
| 440 | #endif | ||
| 441 | #ifdef BSD4_2 /* file gid will be dir gid */ | ||
| 442 | dirname = Ffile_name_directory (filename); | ||
| 443 | if (dirname != Qnil && stat (XSTRING (dirname)->data, &sdir) == 0) | ||
| 444 | values[9] = (sdir.st_gid != s.st_gid) ? Qt : Qnil; | ||
| 445 | else /* if we can't tell, assume worst */ | ||
| 446 | values[9] = Qt; | ||
| 447 | #else /* file gid will be egid */ | ||
| 448 | values[9] = (s.st_gid != getegid ()) ? Qt : Qnil; | ||
| 449 | #endif /* BSD4_2 (or BSD4_3) */ | ||
| 450 | #ifdef BSD4_3 | ||
| 451 | #undef BSD4_2 /* ok, you can look again without throwing up */ | ||
| 452 | #endif | ||
| 453 | values[10] = make_number (s.st_ino); | ||
| 454 | values[11] = make_number (s.st_dev); | ||
| 455 | return Flist (sizeof(values) / sizeof(values[0]), values); | ||
| 456 | } | ||
| 457 | |||
| 458 | syms_of_dired () | ||
| 459 | { | ||
| 460 | defsubr (&Sdirectory_files); | ||
| 461 | defsubr (&Sfile_name_completion); | ||
| 462 | #ifdef VMS | ||
| 463 | defsubr (&Sfile_name_all_versions); | ||
| 464 | #endif /* VMS */ | ||
| 465 | defsubr (&Sfile_name_all_completions); | ||
| 466 | defsubr (&Sfile_attributes); | ||
| 467 | |||
| 468 | #ifdef VMS | ||
| 469 | Qcompletion_ignore_case = intern ("completion-ignore-case"); | ||
| 470 | staticpro (&Qcompletion_ignore_case); | ||
| 471 | #endif /* VMS */ | ||
| 472 | |||
| 473 | DEFVAR_LISP ("completion-ignored-extensions", &Vcompletion_ignored_extensions, | ||
| 474 | "*Completion ignores filenames ending in any string in this list.\n\ | ||
| 475 | This variable does not affect lists of possible completions,\n\ | ||
| 476 | but does affect the commands that actually do completions."); | ||
| 477 | Vcompletion_ignored_extensions = Qnil; | ||
| 478 | } | ||
diff --git a/src/mocklisp.c b/src/mocklisp.c new file mode 100644 index 00000000000..5fb34ae74cc --- /dev/null +++ b/src/mocklisp.c | |||
| @@ -0,0 +1,242 @@ | |||
| 1 | /* Mocklisp compatibility functions for GNU Emacs Lisp interpreter. | ||
| 2 | Copyright (C) 1985, 1986 Free Software Foundation, Inc. | ||
| 3 | |||
| 4 | This file is part of GNU Emacs. | ||
| 5 | |||
| 6 | GNU Emacs is free software; you can redistribute it and/or modify | ||
| 7 | it under the terms of the GNU General Public License as published by | ||
| 8 | the Free Software Foundation; either version 1, or (at your option) | ||
| 9 | any later version. | ||
| 10 | |||
| 11 | GNU Emacs is distributed in the hope that it will be useful, | ||
| 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | GNU General Public License for more details. | ||
| 15 | |||
| 16 | You should have received a copy of the GNU General Public License | ||
| 17 | along with GNU Emacs; see the file COPYING. If not, write to | ||
| 18 | the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ | ||
| 19 | |||
| 20 | |||
| 21 | /* Compatibility for mocklisp */ | ||
| 22 | |||
| 23 | #include "config.h" | ||
| 24 | #include "lisp.h" | ||
| 25 | #include "buffer.h" | ||
| 26 | |||
| 27 | /* Now in lisp code ("macrocode...") | ||
| 28 | * DEFUN ("ml-defun", Fml_defun, Sml_defun, 0, UNEVALLED, 0, | ||
| 29 | * "Define mocklisp functions") | ||
| 30 | * (args) | ||
| 31 | * Lisp_Object args; | ||
| 32 | * { | ||
| 33 | * Lisp_Object elt; | ||
| 34 | * | ||
| 35 | * while (!NULL (args)) | ||
| 36 | * { | ||
| 37 | * elt = Fcar (args); | ||
| 38 | * Ffset (Fcar (elt), Fcons (Qmocklisp, Fcdr (elt))); | ||
| 39 | * args = Fcdr (args); | ||
| 40 | * } | ||
| 41 | * return Qnil; | ||
| 42 | * } | ||
| 43 | */ | ||
| 44 | |||
| 45 | DEFUN ("ml-if", Fml_if, Sml_if, 0, UNEVALLED, 0, "Mocklisp version of `if'.") | ||
| 46 | (args) | ||
| 47 | Lisp_Object args; | ||
| 48 | { | ||
| 49 | register Lisp_Object val; | ||
| 50 | struct gcpro gcpro1; | ||
| 51 | |||
| 52 | GCPRO1 (args); | ||
| 53 | while (!NULL (args)) | ||
| 54 | { | ||
| 55 | val = Feval (Fcar (args)); | ||
| 56 | args = Fcdr (args); | ||
| 57 | if (NULL (args)) break; | ||
| 58 | if (XINT (val)) | ||
| 59 | { | ||
| 60 | val = Feval (Fcar (args)); | ||
| 61 | break; | ||
| 62 | } | ||
| 63 | args = Fcdr (args); | ||
| 64 | } | ||
| 65 | UNGCPRO; | ||
| 66 | return val; | ||
| 67 | } | ||
| 68 | |||
| 69 | /* Now converted to regular "while" by hairier conversion code. | ||
| 70 | * DEFUN ("ml-while", Fml_while, Sml_while, 1, UNEVALLED, 0, "while for mocklisp programs") | ||
| 71 | * (args) | ||
| 72 | * Lisp_Object args; | ||
| 73 | * { | ||
| 74 | * Lisp_Object test, body, tem; | ||
| 75 | * struct gcpro gcpro1, gcpro2; | ||
| 76 | * | ||
| 77 | * GCPRO2 (test, body); | ||
| 78 | * | ||
| 79 | * test = Fcar (args); | ||
| 80 | * body = Fcdr (args); | ||
| 81 | * while (tem = Feval (test), XINT (tem)) | ||
| 82 | * { | ||
| 83 | * QUIT; | ||
| 84 | * Fprogn (body); | ||
| 85 | * } | ||
| 86 | * | ||
| 87 | * UNGCPRO; | ||
| 88 | * return Qnil; | ||
| 89 | *} | ||
| 90 | |||
| 91 | /* This is the main entry point to mocklisp execution. | ||
| 92 | When eval sees a mocklisp function being called, it calls here | ||
| 93 | with the unevaluated argument list */ | ||
| 94 | |||
| 95 | Lisp_Object | ||
| 96 | ml_apply (function, args) | ||
| 97 | Lisp_Object function, args; | ||
| 98 | { | ||
| 99 | register int count = specpdl_ptr - specpdl; | ||
| 100 | register Lisp_Object val; | ||
| 101 | |||
| 102 | specbind (Qmocklisp_arguments, args); | ||
| 103 | val = Fprogn (Fcdr (function)); | ||
| 104 | return unbind_to (count, val); | ||
| 105 | } | ||
| 106 | |||
| 107 | DEFUN ("ml-nargs", Fml_nargs, Sml_nargs, 0, 0, 0, | ||
| 108 | "Number of arguments to currently executing mocklisp function.") | ||
| 109 | () | ||
| 110 | { | ||
| 111 | if (EQ (Vmocklisp_arguments, Qinteractive)) | ||
| 112 | return make_number (0); | ||
| 113 | return Flength (Vmocklisp_arguments); | ||
| 114 | } | ||
| 115 | |||
| 116 | DEFUN ("ml-arg", Fml_arg, Sml_arg, 1, 2, 0, | ||
| 117 | "Argument number N to currently executing mocklisp function.") | ||
| 118 | (n, prompt) | ||
| 119 | Lisp_Object n, prompt; | ||
| 120 | { | ||
| 121 | if (EQ (Vmocklisp_arguments, Qinteractive)) | ||
| 122 | return Fread_string (prompt, Qnil); | ||
| 123 | CHECK_NUMBER (n, 0); | ||
| 124 | XSETINT (n, XINT (n) - 1); /* Mocklisp likes to be origin-1 */ | ||
| 125 | return Fcar (Fnthcdr (n, Vmocklisp_arguments)); | ||
| 126 | } | ||
| 127 | |||
| 128 | DEFUN ("ml-interactive", Fml_interactive, Sml_interactive, 0, 0, 0, | ||
| 129 | "True if currently executing mocklisp function was called interactively.") | ||
| 130 | () | ||
| 131 | { | ||
| 132 | return (EQ (Vmocklisp_arguments, Qinteractive)) ? Qt : Qnil; | ||
| 133 | } | ||
| 134 | |||
| 135 | DEFUN ("ml-provide-prefix-argument", Fml_provide_prefix_argument, Sml_provide_prefix_argument, | ||
| 136 | 2, UNEVALLED, 0, | ||
| 137 | "Evaluate second argument, using first argument as prefix arg value.") | ||
| 138 | (args) | ||
| 139 | Lisp_Object args; | ||
| 140 | { | ||
| 141 | struct gcpro gcpro1; | ||
| 142 | GCPRO1 (args); | ||
| 143 | Vcurrent_prefix_arg = Feval (Fcar (args)); | ||
| 144 | UNGCPRO; | ||
| 145 | return Feval (Fcar (Fcdr (args))); | ||
| 146 | } | ||
| 147 | |||
| 148 | DEFUN ("ml-prefix-argument-loop", Fml_prefix_argument_loop, Sml_prefix_argument_loop, | ||
| 149 | 0, UNEVALLED, 0, | ||
| 150 | "") | ||
| 151 | (args) | ||
| 152 | Lisp_Object args; | ||
| 153 | { | ||
| 154 | register Lisp_Object tem; | ||
| 155 | register int i; | ||
| 156 | struct gcpro gcpro1; | ||
| 157 | |||
| 158 | /* Set `arg' in case we call a built-in function that looks at it. Still are a few. */ | ||
| 159 | if (NULL (Vcurrent_prefix_arg)) | ||
| 160 | i = 1; | ||
| 161 | else | ||
| 162 | { | ||
| 163 | tem = Vcurrent_prefix_arg; | ||
| 164 | if (CONSP (tem)) | ||
| 165 | tem = Fcar (tem); | ||
| 166 | if (EQ (tem, Qminus)) | ||
| 167 | i = -1; | ||
| 168 | else i = XINT (tem); | ||
| 169 | } | ||
| 170 | |||
| 171 | GCPRO1 (args); | ||
| 172 | while (i-- > 0) | ||
| 173 | Fprogn (args); | ||
| 174 | UNGCPRO; | ||
| 175 | return Qnil; | ||
| 176 | } | ||
| 177 | |||
| 178 | #if 0 /* Now in mlsupport.el */ | ||
| 179 | |||
| 180 | DEFUN ("ml-substr", Fml_substr, Sml_substr, 3, 3, 0, | ||
| 181 | "Return a substring of STRING, starting at index FROM and of length LENGTH.\n\ | ||
| 182 | If either FROM or LENGTH is negative, the length of STRING is added to it.") | ||
| 183 | (string, from, to) | ||
| 184 | Lisp_Object string, from, to; | ||
| 185 | { | ||
| 186 | CHECK_STRING (string, 0); | ||
| 187 | CHECK_NUMBER (from, 1); | ||
| 188 | CHECK_NUMBER (to, 2); | ||
| 189 | |||
| 190 | if (XINT (from) < 0) | ||
| 191 | XSETINT (from, XINT (from) + XSTRING (string)->size); | ||
| 192 | if (XINT (to) < 0) | ||
| 193 | XSETINT (to, XINT (to) + XSTRING (string)->size); | ||
| 194 | XSETINT (to, XINT (to) + XINT (from)); | ||
| 195 | return Fsubstring (string, from, to); | ||
| 196 | } | ||
| 197 | #endif NOTDEF | ||
| 198 | DEFUN ("insert-string", Finsert_string, Sinsert_string, 0, MANY, 0, | ||
| 199 | "Mocklisp-compatibility insert function.\n\ | ||
| 200 | Like the function `insert' except that any argument that is a number\n\ | ||
| 201 | is converted into a string by expressing it in decimal.") | ||
| 202 | (nargs, args) | ||
| 203 | int nargs; | ||
| 204 | Lisp_Object *args; | ||
| 205 | { | ||
| 206 | register int argnum; | ||
| 207 | register Lisp_Object tem; | ||
| 208 | |||
| 209 | for (argnum = 0; argnum < nargs; argnum++) | ||
| 210 | { | ||
| 211 | tem = args[argnum]; | ||
| 212 | retry: | ||
| 213 | if (XTYPE (tem) == Lisp_Int) | ||
| 214 | tem = Fint_to_string (tem); | ||
| 215 | if (XTYPE (tem) == Lisp_String) | ||
| 216 | insert1 (tem); | ||
| 217 | else | ||
| 218 | { | ||
| 219 | tem = wrong_type_argument (Qstringp, tem); | ||
| 220 | goto retry; | ||
| 221 | } | ||
| 222 | } | ||
| 223 | return Qnil; | ||
| 224 | } | ||
| 225 | |||
| 226 | |||
| 227 | syms_of_mocklisp () | ||
| 228 | { | ||
| 229 | Qmocklisp = intern ("mocklisp"); | ||
| 230 | staticpro (&Qmocklisp); | ||
| 231 | |||
| 232 | /*defsubr (&Sml_defun);*/ | ||
| 233 | defsubr (&Sml_if); | ||
| 234 | /*defsubr (&Sml_while);*/ | ||
| 235 | defsubr (&Sml_arg); | ||
| 236 | defsubr (&Sml_nargs); | ||
| 237 | defsubr (&Sml_interactive); | ||
| 238 | defsubr (&Sml_provide_prefix_argument); | ||
| 239 | defsubr (&Sml_prefix_argument_loop); | ||
| 240 | /*defsubr (&Sml_substr);*/ | ||
| 241 | defsubr (&Sinsert_string); | ||
| 242 | } | ||