« back to all changes in this revision
Viewing changes to tools/browser/func.c
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: Bazaar Package Importer
- Author(s): Alastair McKinstry
- Date: 2011-01-02 00:03:01 UTC
- Revision ID: james.westby@ubuntu.com-20110102000301-9s2hfsjrkguz6h4r
Tags: upstream-4.8
Import upstream version 4.8
- files added:
- SiloWindows
- SiloWindows/MSVC8
- SiloWindows/MSVC8/Tests
- SiloWindows/MSVC8/bin
- SiloWindows/MSVC8/pdb_detect
- SiloWindows/include
- SiloWindows/resources
- config
- config-site
- config-site/alderaan.conf
- config-site/atlas0.conf
- config-site/atlas1088.conf
- config-site/atlas1120.conf
- config-site/atlas32.conf
- config-site/atlas512.conf
- config-site/atlas544.conf
- config-site/atlas576.conf
- config-site/atlas608.conf
- config-site/bgl1.conf
- config-site/bgl10.conf
- config-site/bgl11.conf
- config-site/bgl2.conf
- config-site/bgl3.conf
- config-site/bgl4.conf
- config-site/bgl5.conf
- config-site/bgl6.conf
- config-site/bgl7.conf
- config-site/bgl8.conf
- config-site/bgl9.conf
- config-site/cslic.conf
- config-site/cslic1.conf
- config-site/cslic2.conf
- config-site/cslic3.conf
- config-site/cslic4.conf
- config-site/cslic5.conf
- config-site/eos.conf
- config-site/eos0.conf
- config-site/eos1.conf
- config-site/hera.conf
- config-site/hera0.conf
- config-site/hera1.conf
- config-site/hera552.conf
- config-site/hera553.conf
- config-site/hera840.conf
- config-site/hera841.conf
- config-site/localhost.conf
- config-site/minos.conf
- config-site/minos0.conf
- config-site/minos32.conf
- config-site/minos512.conf
- config-site/minos544.conf
- config-site/minos576.conf
- config-site/minos608.conf
- config-site/naboo.conf
- config-site/prism1.conf
- config-site/prism2.conf
- config-site/purple.conf
- config-site/purple1441.conf
- config-site/purple1442.conf
- config-site/purple1443.conf
- config-site/purple1444.conf
- config-site/rhea.conf
- config-site/rhea0.conf
- config-site/rhea32.conf
- config-site/rhea512.conf
- config-site/rhea544.conf
- config-site/skywalker.conf
- config-site/sunburn.conf
- config-site/tempest.conf
- config-site/tempest01.conf
- config-site/tempest02.conf
- config-site/ubgl.conf
- config-site/um.conf
- config-site/um006.conf
- config-site/up.conf
- config-site/up038.conf
- config-site/up039.conf
- config-site/up041.conf
- config-site/uv.conf
- config-site/uv006.conf
- config-site/vader.conf
- config-site/yana.conf
- config-site/yana1.conf
- config-site/yana2.conf
- config-site/yana3.conf
- config-site/yana4.conf
- config-site/zeus.conf
- config-site/zeus279.conf
- docs
- src
- src/debug
- src/filters
- src/hdf5_drv
- src/netcdf
- src/pdb
- src/pdb_drv
- src/pdbp_drv
- src/score
- src/silo
- src/taurus
- src/unknown
- svn_bin
- tests
- tools
- tools/browser
- tools/python
- tools/silex
- tools/silock
added
removed
tools/browser/func.c
1
/*
2
Copyright (c) 1994 - 2010, Lawrence Livermore National Security, LLC.
3
LLNL-CODE-425250.
4
All rights reserved.
5
6
This file is part of Silo. For details, see silo.llnl.gov.
7
8
Redistribution and use in source and binary forms, with or without
9
modification, are permitted provided that the following conditions
10
are met:
11
12
* Redistributions of source code must retain the above copyright
13
notice, this list of conditions and the disclaimer below.
14
* Redistributions in binary form must reproduce the above copyright
15
notice, this list of conditions and the disclaimer (as noted
16
below) in the documentation and/or other materials provided with
17
the distribution.
18
* Neither the name of the LLNS/LLNL nor the names of its
19
contributors may be used to endorse or promote products derived
20
from this software without specific prior written permission.
21
22
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
23
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
24
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
25
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL LAWRENCE
26
LIVERMORE NATIONAL SECURITY, LLC, THE U.S. DEPARTMENT OF ENERGY OR
27
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
28
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
29
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
30
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
31
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
32
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
33
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
34
35
This work was produced at Lawrence Livermore National Laboratory under
36
Contract No. DE-AC52-07NA27344 with the DOE.
37
38
Neither the United States Government nor Lawrence Livermore National
39
Security, LLC nor any of their employees, makes any warranty, express
40
or implied, or assumes any liability or responsibility for the
41
accuracy, completeness, or usefulness of any information, apparatus,
42
product, or process disclosed, or represents that its use would not
43
infringe privately-owned rights.
44
45
Any reference herein to any specific commercial products, process, or
46
services by trade name, trademark, manufacturer or otherwise does not
47
necessarily constitute or imply its endorsement, recommendation, or
48
favoring by the United States Government or Lawrence Livermore
49
National Security, LLC. The views and opinions of authors expressed
50
herein do not necessarily state or reflect those of the United States
51
Government or Lawrence Livermore National Security, LLC, and shall not
52
be used for advertising or product endorsement purposes.
53
*/
54
/*-------------------------------------------------------------------------
55
*
56
* Created: func.c
57
* Dec 4 1996
58
* Robb Matzke <matzke@viper.llnl.gov>
59
*
60
* Purpose: Builtin functions.
61
*
62
* Modifications:
63
*
64
* Thomas Treadway, Thu Jun 8 16:56:35 PDT 2006
65
* Modified readline definitions to support new configure macro.
66
*
67
*-------------------------------------------------------------------------
68
*/
69
#include <config.h> /*MeshTV configuration record*/
70
71
#include <assert.h>
72
#include <browser.h>
73
#include <ctype.h>
74
#include <errno.h>
75
#include <fcntl.h>
76
#ifdef HAVE_FNMATCH_H
77
# include <fnmatch.h>
78
# ifndef FNM_FILE_NAME
79
# define FNM_FILE_NAME 0
80
# endif
81
#endif
82
#ifdef HAVE_READLINE_HISTORY
83
# if defined(HAVE_READLINE_HISTORY_H)
84
# include <readline/history.h>
85
# elif defined(HAVE_HISTORY_H)
86
# include <history.h>
87
# else /* !defined(HAVE_HISTORY_H) */
88
extern void add_history ();
89
extern int write_history ();
90
extern int read_history ();
91
# endif /* defined(HAVE_READLINE_HISTORY_H) */
92
/* no history */
93
#endif /* HAVE_READLINE_HISTORY */
94
#include <stdlib.h>
95
#include <sys/wait.h>
96
#include <unistd.h>
97
98
/* Non-posix functions */
99
extern FILE *popen (const char *, const char *);
100
extern int pclose (FILE*);
101
102
/* Global variables. */
103
diffopt_t DiffOpt;
104
helptoc_t HelpFuncToc[25];
105
int NHelpFuncToc;
106
helptoc_t HelpVarToc[50];
107
int NHelpVarToc;
108
helptoc_t HelpOpToc[25];
109
int NHelpOpToc;
110
111
112
/*-------------------------------------------------------------------------
113
* Function: V_array
114
*
115
* Purpose: Creates a new array type.
116
*
117
* Return: Success: Ptr to new array type.
118
*
119
* Failure: NIL
120
*
121
* Programmer: Robb Matzke
122
* matzke@viper.llnl.gov
123
* Dec 6 1996
124
*
125
* Modifications:
126
*
127
* Robb Matzke, 30 Jul 1997
128
* Fixed a bug with the comma disappearing between string arguments.
129
*
130
*-------------------------------------------------------------------------
131
*/
132
obj_t
133
V_array (int argc, obj_t argv[]) {
134
135
char buf[1024];
136
int i, at=0;
137
char *s;
138
139
if (argc<2) {
140
out_errorn ("Array: wrong number of arguments");
141
return NIL;
142
}
143
144
buf[0] = '\0';
145
for (i=0; i<argc-1; i++) {
146
if (argv[i] && C_NUM==argv[i]->pub.cls) {
147
sprintf (buf+at, "%s%d", at?", ":"", num_int (argv[i]));
148
at += strlen (buf+at);
149
150
} else if (argv[i] && (s=obj_name(argv[i]))) {
151
if (at) {
152
buf[at++] = ',';
153
buf[at++] = ' ';
154
}
155
strcpy (buf+at, s);
156
at += strlen (buf+at);
157
158
} else {
159
out_error ("Array: inappropriate dimension: ", argv[i]);
160
return NIL;
161
}
162
}
163
164
return obj_new (C_ARY, buf, obj_copy (argv[argc-1], SHALLOW));
165
}
166
167
168
/*-------------------------------------------------------------------------
169
* Function: V_assign
170
*
171
* Purpose: Assigns an RVALUE to an LVALUE. If LVALUE is a symbol
172
* that has a variable value, then we assign RVALUE to that
173
* symbol. Otherwise, if LVALUE evaluates to an silo data
174
* object, we assign RVALUE to that SDO. Otherwise if LVALUE
175
* (unevaluated) is a symbol we assign RVALUE to that new
176
* symbol.
177
*
178
* Return: Success: The RVALUE
179
*
180
* Failure: NIL
181
*
182
* Programmer: Robb Matzke
183
* robb@maya.nuance.mdn.com
184
* Feb 7 1997
185
*
186
* Modifications:
187
*
188
* Robb Matzke, 19 Feb 1997
189
* Supports assignments to silo data objects.
190
*
191
*-------------------------------------------------------------------------
192
*/
193
obj_t
194
V_assign (int argc, obj_t argv[]) {
195
196
int isa_symbol;
197
obj_t val=NIL, retval=NIL;
198
199
if (2!=argc) {
200
out_errorn ("Assign: wrong number of arguments");
201
return NIL;
202
}
203
204
if (!argv[0]) return NIL; /*error detected below*/
205
isa_symbol = (C_SYM == argv[0]->pub.cls);
206
207
/*
208
* The LVALUE is a symbol with a variable value. Make the RVALUE the
209
* new variable value for that symbol.
210
*/
211
if (isa_symbol && (val=sym_vboundp(argv[0]))) {
212
val = obj_dest (val);
213
sym_vbind (argv[0], obj_copy (argv[1], SHALLOW));
214
return obj_copy (argv[1], SHALLOW);
215
}
216
217
/*
218
* Eval the LVALUE to see if it's a silo data object.
219
*/
220
out_error_disable();
221
val = obj_eval (argv[0]);
222
out_error_restore();
223
if (val && C_SDO==val->pub.cls) {
224
retval = sdo_assign (val, argv[1]);
225
val = obj_dest (val);
226
return retval;
227
}
228
val = obj_dest (val);
229
230
/*
231
* The LVALUE is a symbol that doesn't evaluate to a silo data object.
232
* Assign the RVALUE as the variable value of the symbol.
233
*/
234
if (isa_symbol) {
235
sym_vbind (argv[0], obj_copy (argv[1], SHALLOW));
236
return obj_copy (argv[1], SHALLOW);
237
}
238
239
/*
240
* The LVALUE is not a symbol and doesn't evaluate to a silo
241
* data object.
242
*/
243
out_errorn ("Assign: left operand has no L-value");
244
return NIL;
245
}
246
247
248
/*-------------------------------------------------------------------------
249
* Function: V_close
250
*
251
* Purpose: Closes the files associated with the specified symbols.
252
*
253
* Return: Success: NIL
254
*
255
* Failure: NIL
256
*
257
* Programmer: Robb Matzke
258
* robb@maya.nuance.mdn.com
259
* Jan 20 1997
260
*
261
* Modifications:
262
*
263
* Robb Matzke, 3 Feb 1997
264
* Cleaned up error messages.
265
*-------------------------------------------------------------------------
266
*/
267
obj_t
268
V_close (int argc, obj_t argv[]) {
269
270
int i;
271
char ebuf[1024];
272
obj_t file=NIL;
273
274
for (i=0; i<argc; i++) {
275
if (!argv[i] || C_SYM!=argv[i]->pub.cls) {
276
sprintf (ebuf, "close: inappropriate file symbol as arg-%d: ", i+1);
277
out_error (ebuf, argv[i]);
278
} else if (NIL==(file=sym_vboundp(argv[i])) || C_FILE!=file->pub.cls) {
279
out_errorn ("close: no file associated with %s", obj_name(argv[i]));
280
file = obj_dest (file);
281
} else {
282
file = obj_dest (file);
283
sym_vbind (argv[i], NIL);
284
}
285
}
286
return NIL;
287
}
288
289
290
/*-------------------------------------------------------------------------
291
* Function: F_cons
292
*
293
* Purpose: Creates a new cons cell with a HEAD and TAIL.
294
*
295
* Return: Success: Ptr to new cons cell.
296
*
297
* Failure: NIL
298
*
299
* Programmer: Robb Matzke
300
* matzke@viper.llnl.gov
301
* Dec 4 1996
302
*
303
* Modifications:
304
*
305
*-------------------------------------------------------------------------
306
*/
307
obj_t
308
F_cons (obj_t head, obj_t tail) {
309
310
return obj_new (C_CONS, obj_copy(head, SHALLOW), obj_copy(tail, SHALLOW));
311
}
312
313
314
/*-------------------------------------------------------------------------
315
* Function: diff_lookup
316
*
317
* Purpose: Looks up a diff constant in the symbol table and returns
318
* its value. If the symbol has a value which is not a
319
* number or a value which is a negative number then the value
320
* is removed with a warning.
321
*
322
* Return: Success: Double value of the variable.
323
*
324
* Failure: -1.0
325
*
326
* Programmer: Robb Matzke
327
* robb@maya.nuance.mdn.com
328
* Feb 6 1997
329
*
330
* Modifications:
331
*
332
* Mark C. Miller, Tue Nov 17 22:34:51 PST 2009
333
* Added logic to exclude epsilon diff params from requirement to not be
334
* less than zero.
335
*-------------------------------------------------------------------------
336
*/
337
static double
338
diff_lookup (char *ascii_name) {
339
340
obj_t name=NIL, val=NIL;
341
char buf[1024];
342
double retval = -1.0;
343
344
345
name = obj_new (C_SYM, ascii_name);
346
if ((val=sym_vboundp(name))) {
347
if (!num_isfp(val)) {
348
sprintf (buf, "diff: value of `%s' is inappropriate: ", ascii_name);
349
out_error (buf, val);
350
sym_vbind (name, NIL);
351
} else if ((retval=num_fp(val))<0.0 && !strstr(ascii_name, "_eps")) {
352
out_errorn ("diff: value of `%s' is inappropriate: %d",
353
ascii_name, retval);
354
sym_vbind (name, NIL);
355
retval = -1.0;
356
}
357
val = obj_dest (val);
358
}
359
name = obj_dest (name);
360
361
if (Verbosity>=2) {
362
if (retval<=0.0) {
363
out_info ("diff: %-15s is disabled", ascii_name);
364
} else {
365
out_info ("diff: %-15s = %e", ascii_name, retval);
366
}
367
}
368
369
return retval;
370
}
371
372
373
/*-------------------------------------------------------------------------
374
* Function: V_diff
375
*
376
* Purpose: Determines whether two things differ.
377
*
378
* Return: Success: NIL
379
*
380
* Failure: NIL
381
*
382
* Programmer: Robb Matzke
383
* robb@maya.nuance.mdn.com
384
* Jan 21 1997
385
*
386
* Modifications:
387
* Robb Matzke, 2000-06-27
388
* Added the `two_column' diff option.
389
*
390
* Robb Matzke, 2000-06-28
391
* If more than two arguments are given then the argument
392
* list is split in half and operands from the first half are
393
* differenced against corresponding operands from the second
394
* half. If called with no arguments then the command-line
395
* database files are used as arguments.
396
*
397
* Robb Matzke, 2000-06-29
398
* The contents of the $exclude variable is parsed and cached
399
* in the DiffOpts.
400
*
401
* Robb Matzke, 2000-07-05
402
* If invoked with one argument and that argument is a silo
403
* database object from file $1 then it will be differenced
404
* against an object of the same name from file $2.
405
*
406
* Robb Matzke, 2000-07-10
407
* Fixed a memory corruption bug when called with no
408
* arguments and no files opened on the command-line
409
*
410
* Mark C. Miller, Wed Nov 11 22:18:17 PST 2009
411
* Added suppot for alternate relative diff option using
412
* epsilon.
413
*
414
* Mark C. Miller, Mon Jan 11 16:21:21 PST 2010
415
* Added support for long long diffing params.
416
*-------------------------------------------------------------------------
417
*/
418
obj_t
419
V_diff (int argc, obj_t argv[])
420
{
421
int status;
422
int old_rtmargin = OUT_STDOUT->rtmargin;
423
obj_t opands[1024], head=NIL, value=NIL, symbol=NIL, word=NIL;
424
int nopands=0, i, j;
425
426
memset(&DiffOpt, 0, sizeof DiffOpt);
427
428
if (0==argc) {
429
/* When invoked with no arguments use the list of command-line
430
* files as arguments. */
431
for (nopands=0; nopands<NELMTS(opands); nopands++) {
432
char tmp[32];
433
434
sprintf(tmp, "$%d", nopands+1);
435
symbol = obj_new(C_SYM, tmp);
436
opands[nopands] = sym_vboundp(symbol);
437
symbol = obj_dest(symbol);
438
if (!opands[nopands] || C_FILE!=opands[nopands]->pub.cls) {
439
/*we reached the last file or something isn't a file*/
440
opands[nopands] = obj_dest(opands[nopands]);
441
break;
442
}
443
}
444
} else if (1==argc) {
445
/* When invoked with one argument which is a silo object from the
446
* file represented by `$1', the second argument is the silo
447
* object of the same name from file `$2'. */
448
obj_t my_file=NIL, file_1=NIL, file_2=NIL;
449
450
if (!argv[0] || C_SDO!=argv[0]->pub.cls) {
451
out_errorn("diff: single-argument must be a silo object");
452
goto done;
453
}
454
my_file = sdo_file(argv[0]);
455
456
symbol = obj_new(C_SYM, "$1");
457
file_1 = sym_vboundp(symbol);
458
symbol = obj_dest(symbol);
459
if (!file_1 || C_FILE!=file_1->pub.cls) {
460
out_errorn("diff: single-argument must be from file $1");
461
my_file = obj_dest(my_file);
462
file_1 = obj_dest(file_1);
463
goto done;
464
}
465
if (strcmp(obj_name(my_file), obj_name(file_1))) {
466
out_errorn("diff: single-argument must be from file $1");
467
my_file = obj_dest(my_file);
468
file_1 = obj_dest(file_1);
469
goto done;
470
}
471
my_file = obj_dest(my_file);
472
file_1 = obj_dest(file_1);
473
474
475
symbol = obj_new(C_SYM, "$2");
476
file_2 = sym_vboundp(symbol);
477
symbol = obj_dest(symbol);
478
if (!file_2 || C_FILE!=file_2->pub.cls) {
479
out_errorn("diff: file $2 is not defined");
480
file_2 = obj_dest(file_2);
481
goto done;
482
}
483
484
symbol = obj_new(C_SYM, obj_name(argv[0]));
485
opands[nopands++] = obj_copy(argv[0], SHALLOW);
486
opands[nopands++] = obj_deref(file_2, 1, &symbol);
487
symbol = obj_dest(symbol);
488
489
} else {
490
for (nopands=0; nopands<argc && nopands<NELMTS(opands); nopands++) {
491
opands[nopands] = obj_copy(argv[nopands], SHALLOW);
492
}
493
}
494
495
/* The number of operands had better be even */
496
if (nopands % 2) {
497
out_errorn("diff requires an even number of arguments or "
498
"command-line database files");
499
goto done;
500
}
501
if (0==nopands) {
502
out_errorn("nothing to difference");
503
goto done;
504
}
505
506
/* Parse and cache $diff value */
507
symbol = obj_new(C_SYM, "$diff");
508
head = sym_vboundp(symbol);
509
symbol = obj_dest(symbol);
510
if (head && C_CONS!=head->pub.cls) {
511
head = obj_new(C_CONS, obj_copy(head, SHALLOW), NIL);
512
}
513
for (value=head; value; value=cons_tail(value)) {
514
if (C_CONS!=value->pub.cls) {
515
out_errorn("diff: invalid value for $diff");
516
goto done;
517
}
518
word = cons_head(value);
519
if (C_SYM==word->pub.cls) {
520
if (!strcmp(obj_name(word), "all")) {
521
DiffOpt.report = DIFF_REP_ALL;
522
} else if (!strcmp(obj_name(word), "detail")) {
523
DiffOpt.report = DIFF_REP_ALL;
524
} else if (!strcmp(obj_name(word), "detailed")) {
525
DiffOpt.report = DIFF_REP_ALL;
526
} else if (!strcmp(obj_name(word), "brief")) {
527
DiffOpt.report = DIFF_REP_BRIEF;
528
} else if (!strcmp(obj_name(word), "sum")) {
529
DiffOpt.report = DIFF_REP_SUMMARY;
530
} else if (!strcmp(obj_name(word), "summary")) {
531
DiffOpt.report = DIFF_REP_SUMMARY;
532
} else if (!strcmp(obj_name(word), "summarize")) {
533
DiffOpt.report = DIFF_REP_SUMMARY;
534
} else if (!strcmp(obj_name(word), "ignore_additions")) {
535
DiffOpt.ignore_adds = true;
536
} else if (!strcmp(obj_name(word), "ignore_deletions")) {
537
DiffOpt.ignore_dels = true;
538
} else if (!strcmp(obj_name(word), "two_column")) {
539
DiffOpt.two_column = true;
540
} else {
541
out_errorn("word `%s' of $diff isn't recognized (ignored)",
542
obj_name(word));
543
}
544
} else {
545
out_errorn("diff: invalid value for $diff");
546
goto done;
547
}
548
}
549
head = obj_dest(head);
550
551
/* Parse and cache $exclude values */
552
symbol = obj_new(C_SYM, "$exclude");
553
head = sym_vboundp(symbol);
554
symbol = obj_dest(symbol);
555
if (head && C_CONS!=head->pub.cls) {
556
head = obj_new(C_CONS, obj_copy(head, SHALLOW), NIL);
557
}
558
for (value=head; value; value=cons_tail(value)) {
559
if (C_CONS!=value->pub.cls) {
560
out_errorn("diff: invalid value for $exclude");
561
goto done;
562
}
563
if (DiffOpt.exclude.nused>=NELMTS(DiffOpt.exclude.value)) {
564
out_errorn("diff: too many exclusions (limit %lu)",
565
(unsigned long)NELMTS(DiffOpt.exclude.value));
566
goto done;
567
}
568
word = cons_head(value);
569
if (C_STR==word->pub.cls) {
570
i = DiffOpt.exclude.nused++;
571
DiffOpt.exclude.value[i] = safe_strdup(obj_name(word));
572
#ifndef HAVE_FNMATCH
573
if (strpbrk(DiffOpt.exclude.value[i], "*?[]")) {
574
out_errorn("diff: $exclude = \"%s\" contains wildcards but "
575
"your C library doesn't have the `fnmatch' "
576
"function. Names will be matched literally.",
577
DiffOpt.exclude.value[i]);
578
}
579
#endif
580
} else {
581
out_errorn("diff: $exclude values should be strings");
582
goto done;
583
}
584
}
585
head = obj_dest(head);
586
587
/* Cache tolerances */
588
DiffOpt.c_abs = diff_lookup("$diff_int8_abs");
589
DiffOpt.c_rel = diff_lookup("$diff_int8_rel");
590
DiffOpt.c_eps = diff_lookup("$diff_int8_eps");
591
DiffOpt.s_abs = diff_lookup("$diff_short_abs");
592
DiffOpt.s_rel = diff_lookup("$diff_short_rel");
593
DiffOpt.s_eps = diff_lookup("$diff_short_eps");
594
DiffOpt.i_abs = diff_lookup("$diff_int_abs");
595
DiffOpt.i_rel = diff_lookup("$diff_int_rel");
596
DiffOpt.i_eps = diff_lookup("$diff_int_eps");
597
DiffOpt.l_abs = diff_lookup("$diff_long_abs");
598
DiffOpt.l_rel = diff_lookup("$diff_long_rel");
599
DiffOpt.l_eps = diff_lookup("$diff_long_eps");
600
DiffOpt.f_abs = diff_lookup("$diff_float_abs");
601
DiffOpt.f_rel = diff_lookup("$diff_float_rel");
602
DiffOpt.f_eps = diff_lookup("$diff_float_eps");
603
DiffOpt.d_abs = diff_lookup("$diff_double_abs");
604
DiffOpt.d_rel = diff_lookup("$diff_double_rel");
605
DiffOpt.d_eps = diff_lookup("$diff_double_eps");
606
DiffOpt.ll_abs = diff_lookup("$diff_llong_abs");
607
DiffOpt.ll_rel = diff_lookup("$diff_llong_rel");
608
DiffOpt.ll_eps = diff_lookup("$diff_llong_eps");
609
610
611
for (i=0; i<nopands/2; i++) {
612
char header[8192], a_buf[32], b_buf[32];
613
const char *a_name, *b_name;
614
615
/* Print a table header for each pair of arguments */
616
if (NULL==(a_name=obj_name(opands[i]))) {
617
sprintf(a_buf, "Argument %d", i+1);
618
a_name = a_buf;
619
}
620
if (NULL==(b_name=obj_name(opands[nopands/2+i]))) {
621
sprintf(b_buf, "Argument %d", nopands/2+i+1);
622
b_name = b_buf;
623
}
624
625
/* Skip a line between each pair of arguments */
626
strcpy(header, i?"\n":"");
627
628
/* Choose a header line appropriate for the output style */
629
if (DIFF_REP_ALL==DiffOpt.report && DiffOpt.two_column) {
630
sprintf(header+strlen(header), "%-*s%-*s%*s%s\n",
631
OUT_LTMAR, "Object", OUT_COL2-OUT_LTMAR, a_name,
632
(int)strlen(DIFF_SEPARATOR), "", b_name);
633
OUT_STDOUT->rtmargin = 0; /*don't split long lines*/
634
} else {
635
sprintf(header+strlen(header), "Differences between %s and %s\n",
636
a_name, b_name);
637
}
638
639
/* Put a line below the header */
640
for (j=0; j<OUT_NCOLS-2; j++) strcat(header, "-");
641
out_header(OUT_STDOUT, header);
642
643
/* The difference... */
644
status = obj_diff(opands[i], opands[nopands/2+i]);
645
if (!out_brokenpipe(OUT_STDOUT)) {
646
switch (DiffOpt.report) {
647
case DIFF_REP_ALL:
648
if (2==status) {
649
out_line(OUT_STDOUT, "***************");
650
obj_print(opands[i], OUT_STDOUT);
651
out_line(OUT_STDOUT, "---------------");
652
obj_print(opands[nopands/2+i], OUT_STDOUT);
653
out_line(OUT_STDOUT, "***************");
654
}
655
break;
656
case DIFF_REP_BRIEF:
657
if (2==status) {
658
out_puts(OUT_STDOUT, "different value(s)");
659
out_nl(OUT_STDOUT);
660
}
661
break;
662
case DIFF_REP_SUMMARY:
663
if (status>0) {
664
out_line(OUT_STDOUT, "objects differ");
665
}
666
break;
667
}
668
}
669
}
670
671
done:
672
/* Restore output margins and cancel table headers*/
673
OUT_STDOUT->rtmargin = old_rtmargin;
674
out_header(OUT_STDOUT, NULL);
675
676
/* Free temp expressions */
677
obj_dest(symbol);
678
obj_dest(head);
679
680
/* Free operands */
681
for (i=0; i<nopands; i++) obj_dest(opands[i]);
682
683
/* Free DiffOpt */
684
for (i=0; i<DiffOpt.exclude.nused; i++) {
685
if (DiffOpt.exclude.value[i]) {
686
free(DiffOpt.exclude.value[i]);
687
DiffOpt.exclude.value[i] = NULL;
688
}
689
}
690
691
return NIL;
692
}
693
694
695
/*-------------------------------------------------------------------------
696
* Function: V_dot
697
*
698
* Purpose: A binary operator. The left operand should be a file
699
* and the right operand should be an object name within
700
* that file.
701
*
702
* Or the left operand should be memory with a structure
703
* type and the right operand should be a field name within
704
* that structure.
705
*
706
* Or the left operand should be memory with an array type
707
* and the right operand(s) should be indices or ranges
708
* thereof.
709
*
710
* Return: Success: Ptr to a SILO database object.
711
*
712
* Failure: NULL
713
*
714
* Programmer: Robb Matzke
715
* matzke@viper.llnl.gov
716
* Dec 5 1996
717
*
718
* Modifications:
719
*
720
* Robb Matzke, 4 Feb 1997
721
* More than one argument is allowed.
722
*
723
*-------------------------------------------------------------------------
724
*/
725
obj_t
726
V_dot (int argc, obj_t argv[]) {
727
728
obj_t retval=NIL;
729
730
if (argv[0]) {
731
retval = obj_deref(argv[0], argc-1, argv+1);
732
} else {
733
out_error ("Dot: inappropriate left operand: ", argv[0]);
734
}
735
736
return retval;
737
}
738
739
740
/*-------------------------------------------------------------------------
741
* Function: V_exit
742
*
743
* Purpose: Exit the program. If a numeric argument is specified then
744
* we exit with that value.
745
*
746
* Return: Success: Does not return
747
*
748
* Failure: NIL
749
*
750
* Programmer: Robb Matzke
751
* matzke@viper.llnl.gov
752
* Dec 4 1996
753
*
754
* Modifications:
755
*
756
* Robb Matzke, 3 Feb 1997
757
* If an argument is supplied then it must be an integer.
758
*
759
* Robb Matzke, 10 Feb 1997
760
* History is saved in a history file.
761
*
762
* Sean Ahern, Fri Feb 28 14:12:58 PST 1997
763
* Added a check for the readline library.
764
*
765
* Thomas R. Treadway, Tue Jun 27 13:59:21 PDT 2006
766
* Added HAVE_STRERROR wrapper
767
*
768
* Thomas R. Treadway, Thu Mar 1 09:37:31 PST 2007
769
* Corrected write history logic
770
*
771
*-------------------------------------------------------------------------
772
*/
773
obj_t
774
V_exit (int argc, obj_t argv[]) {
775
776
#if defined(HAVE_READLINE_HISTORY_H) && defined(HISTORY_FILE) && defined(HAVE_READLINE_HISTORY)
777
if (HistoryFile[0] && write_history (HistoryFile))
778
;
779
else
780
{
781
#ifdef HAVE_STRERROR
782
out_errorn ("command history not saved in %s (%s)",
783
HistoryFile, strerror(errno));
784
#else
785
out_errorn ("command history not saved in %s (errno=%d)",
786
HistoryFile, errno);
787
#endif
788
}
789
#endif
790
791
if (0==argc) {
792
exit (0);
793
794
}
795
if (1==argc) {
796
if (!num_int(argv[0])) {
797
out_errorn ("exit: arg-1 is not an integer");
798
return NIL;
799
}
800
exit (num_int(argv[0]));
801
}
802
803
out_errorn ("exit: wrong number of arguments");
804
return NIL;
805
}
806
807
808
/*-------------------------------------------------------------------------
809
* Function: F_fbind
810
*
811
* Purpose: Bind a function to a name.
812
*
813
* Return: void
814
*
815
* Programmer: Robb Matzke
816
* matzke@viper.llnl.gov
817
* Dec 4 1996
818
*
819
* Modifications:
820
*
821
*-------------------------------------------------------------------------
822
*/
823
void
824
F_fbind (obj_t self, obj_t func) {
825
826
assert (self && C_SYM==self->pub.cls);
827
sym_fbind (self, obj_copy(func, SHALLOW));
828
}
829
830
831
/*-------------------------------------------------------------------------
832
* Function: V_file
833
*
834
* Purpose: Opens a SILO file but does not associate that file with
835
* a symbol. Thus, as soon as all references to this file
836
* object dissappear, the file is closed.
837
*
838
* Return: Success: Ptr to a silo file object.
839
*
840
* Failure: NIL
841
*
842
* Programmer: Robb Matzke
843
* matzke@viper.llnl.gov
844
* Dec 4 1996
845
*
846
* Modifications:
847
*
848
* Robb Matzke, 7 Feb 1997
849
* Changed the name of this function from F_open to V_file.
850
*
851
* Robb Matzke, 2 Apr 1997
852
* If `$rdonly' is true then the file is open for reading only.
853
*
854
*-------------------------------------------------------------------------
855
*/
856
obj_t
857
V_file (int argc, obj_t argv[]) {
858
859
obj_t retval=NIL, filename=NIL;
860
char *fname;
861
int rdonly = sym_bi_true("rdonly");
862
863
if (1!=argc) {
864
out_errorn ("file: wrong number of arguments");
865
return NIL;
866
}
867
filename = argv[0];
868
869
if (!filename) {
870
out_errorn ("file: no file name given");
871
872
} else if (C_FILE==filename->pub.cls) {
873
retval = obj_copy (filename, SHALLOW); /*already opened*/
874
875
} else if (NULL==(fname=obj_name(filename))) {
876
out_errorn ("file: arg-1 is inappropriate");
877
878
} else if (NIL==(retval=obj_new (C_FILE, fname, rdonly))) {
879
#if 0 /*error message already printed*/
880
out_errorn ("file: could not open `%s'", fname);
881
#endif
882
}
883
return retval;
884
}
885
886
887
/*-------------------------------------------------------------------------
888
* Function: F_flatten
889
*
890
* Purpose: Flattens a list so (a (b (c)) d) becomes (a b c d).
891
*
892
* Return: Success: A new list with shallow copies of the atoms.
893
*
894
* Failure: NIL
895
*
896
* Programmer: Robb Matzke
897
* robb@maya.nuance.mdn.com
898
* Apr 3 1997
899
*
900
* Modifications:
901
*
902
*-------------------------------------------------------------------------
903
*/
904
obj_t
905
F_flatten (obj_t lst) {
906
907
obj_t opstack=NIL;
908
obj_t ptr=NIL;
909
obj_t retval=NIL;
910
911
if (!lst || C_CONS!=lst->pub.cls) {
912
return obj_copy (lst, SHALLOW); /*nothing to flatten*/
913
}
914
915
/*
916
* Create a stack of all the atoms.
917
*/
918
for (/*void*/; lst; lst=cons_tail(lst)) {
919
obj_t hd = cons_head (lst);
920
if (!hd) {
921
/*
922
* Head is NIL
923
*/
924
opstack = obj_new (C_CONS, NIL, opstack);
925
926
} else if (C_CONS==hd->pub.cls) {
927
/*
928
* Head is a list. Flatten it and then add those elements
929
* into the opstack.
930
*/
931
obj_t flattened = F_flatten (hd);
932
for (ptr=flattened; ptr; ptr=cons_tail(ptr)) {
933
opstack = obj_new (C_CONS, F_head(ptr), opstack);
934
}
935
flattened = obj_dest (flattened);
936
937
} else {
938
/*
939
* Add a copy of the head to the opstack.
940
*/
941
opstack = obj_new (C_CONS, obj_copy(hd, SHALLOW), opstack);
942
}
943
}
944
945
/*
946
* Return the reversal of the stack.
947
*/
948
retval = F_reverse (opstack);
949
opstack = obj_dest (opstack);
950
return retval;
951
}
952
953
954
/*-------------------------------------------------------------------------
955
* Function: F_head
956
*
957
* Purpose: Returns the head of a list.
958
*
959
* Return: Success: Ptr to the head.
960
*
961
* Failure: NIL
962
*
963
* Programmer: Robb Matzke
964
* matzke@viper.llnl.gov
965
* Dec 4 1996
966
*
967
* Modifications:
968
*
969
*-------------------------------------------------------------------------
970
*/
971
obj_t
972
F_head (obj_t lst) {
973
974
if (!lst) return NIL;
975
if (C_CONS!=lst->pub.cls) return NIL;
976
977
return obj_copy (cons_head(lst), SHALLOW);
978
}
979
980
/*---------------------------------------------------------------------------
981
* Purpose: Callback for help apropos function.
982
*
983
* Programmer: Robb Matzke
984
* Wednesday, June 7, 2000
985
*
986
* Modifications:
987
*---------------------------------------------------------------------------
988
*/
989
static int
990
help_apropos(obj_t sym, void *cdata)
991
{
992
const char *s = (const char*)cdata;
993
obj_t doc = sym_dboundp(sym);
994
int found = false;
995
996
if (doc && C_STR==doc->pub.cls) {
997
const char *docstr = obj_name(doc);
998
if (strstr(obj_name(sym), s) || strstr(docstr, s)) {
999
char buf[256];
1000
sprintf(buf, "help %s", obj_name(sym));
1001
out_line(OUT_STDOUT, buf);
1002
found = true;
1003
}
1004
}
1005
obj_dest(doc);
1006
return found;
1007
}
1008
1009
1010
/*-------------------------------------------------------------------------
1011
* Function: V_help
1012
*
1013
* Purpose: Offers help.
1014
*
1015
* Return: Success: NIL
1016
*
1017
* Failure: NIL
1018
*
1019
* Programmer: Robb Matzke
1020
* robb@maya.nuance.mdn.com
1021
* Feb 3 1997
1022
*
1023
* Modifications:
1024
*
1025
* Robb Matzke, 2000-06-02
1026
* Real users want a quick-and-dirty text-based help system a la
1027
* meshtvx. This command takes zero or one argument. When invoked
1028
* with zero arguments is prints a table of contents (TOC). When
1029
* invoked with a symbol name it prints the documentation string for
1030
* that symbol. When invoked with a string it searches all symbols
1031
* for the specified word and prints those that match. When invoked
1032
* with a symbol and a string it assigns the string as the
1033
* documentation for the symbol and returns null.
1034
*-------------------------------------------------------------------------
1035
*/
1036
obj_t
1037
V_help (int argc, obj_t argv[])
1038
{
1039
int i, is_run;
1040
obj_t doc=NIL, sym=NIL;
1041
static int ncalls=0;
1042
static helptoc_t toc[] = {
1043
{"help", "Help on the `help' function"},
1044
{"delta", "Changes since previous version"},
1045
{"faq", "Frequently asked questions"},
1046
{"run", "Browser execution and switches"},
1047
{"syntax", "Browser syntax"},
1048
{"functions", "Built-in functions"},
1049
{"operators", "Operators and precedence"},
1050
{"variables", "Predefined variables"},
1051
{"formats", "Data output formats"},
1052
{"paging", "Paging long output"},
1053
{"redirection", "Piping and output redirection"},
1054
{"interrupts", "Interrupting long-running commands"},
1055
{"traps", "Traps for the unwary"},
1056
{"$FOO", "Help for variable $FOO"},
1057
{"--FOO", "Help for command-line switch --FOO"},
1058
{"FOO", "Help for built-in function FOO"},
1059
{"\"opFOO\"", "Help for operator FOO"},
1060
{"\"FOO\"", "Help containing string \"FOO\""},
1061
};
1062
1063
if (0==ncalls++) {
1064
/* Table of Contents */
1065
obj_t type = obj_new(C_STC, NULL, NULL);
1066
for (i=0; i<NELMTS(toc); i++) {
1067
char buf[32];
1068
sprintf(buf, "help %s", toc[i].name);
1069
stc_add(type, obj_new(C_PRIM, "string"),
1070
i*sizeof(*toc)+sizeof(char*), buf);
1071
}
1072
doc = obj_new(C_SDO, NIL, NULL, toc, type, toc, type,
1073
NULL, NULL, NULL);
1074
sym = obj_new(C_SYM, "$toc");
1075
sym_dbind(sym, doc);
1076
obj_dest(sym);
1077
obj_dest(type);
1078
1079
/* Function list */
1080
type = obj_new(C_STC, NULL, NULL);
1081
for (i=0; i<NHelpFuncToc; i++) {
1082
char buf[32];
1083
sprintf(buf, "help %s", HelpFuncToc[i].name);
1084
stc_add(type, obj_new(C_PRIM, "string"),
1085
i*sizeof(helptoc_t)+sizeof(char*), buf);
1086
}
1087
doc = obj_new(C_SDO, NIL, NULL, HelpFuncToc, type, HelpFuncToc, type,
1088
NULL, NULL, NULL);
1089
sym = obj_new(C_SYM, "functions");
1090
sym_dbind(sym, doc);
1091
obj_dest(sym);
1092
obj_dest(type);
1093
1094
/* Operator list */
1095
type = obj_new(C_STC, NULL, NULL);
1096
for (i=0; i<NHelpOpToc; i++) {
1097
char buf[32];
1098
sprintf(buf, "help %s", HelpOpToc[i].name);
1099
stc_add(type, obj_new(C_PRIM, "string"),
1100
i*sizeof(helptoc_t)+sizeof(char*), buf);
1101
}
1102
doc = obj_new(C_SDO, NIL, NULL, HelpOpToc, type, HelpOpToc, type,
1103
NULL, NULL, NULL);
1104
sym = obj_new(C_SYM, "operators");
1105
sym_dbind(sym, doc);
1106
obj_dest(sym);
1107
obj_dest(type);
1108
1109
/* Variable list */
1110
type = obj_new(C_STC, NULL, NULL);
1111
for (i=0; i<NHelpVarToc; i++) {
1112
char buf[32];
1113
sprintf(buf, "help %s", HelpVarToc[i].name);
1114
stc_add(type, obj_new(C_PRIM, "string"),
1115
i*sizeof(helptoc_t)+sizeof(char*), buf);
1116
}
1117
doc = obj_new(C_SDO, NIL, NULL, HelpVarToc, type, HelpVarToc, type,
1118
NULL, NULL, NULL);
1119
sym = obj_new(C_SYM, "variables");
1120
sym_dbind(sym, doc);
1121
obj_dest(sym);
1122
obj_dest(type);
1123
}
1124
1125
/* Obtain the symbol */
1126
if (0==argc) {
1127
sym = obj_new(C_SYM, "$toc");
1128
} else if (!argv[0]) {
1129
out_errorn("help: first argument cannot be NIL");
1130
return NIL;
1131
} else if (C_STR==argv[0]->pub.cls) {
1132
const char *s = obj_name(argv[0]);
1133
if (!strncmp("op", s, 2) && s[2]) {
1134
sym = obj_new(C_SYM, s);
1135
} else {
1136
if (!sym_map(help_apropos, (void*)s)) {
1137
out_errorn("help: nothing appropriate");
1138
}
1139
return NIL;
1140
}
1141
} else if (C_SYM==argv[0]->pub.cls) {
1142
sym = argv[0];
1143
} else {
1144
out_errorn("help: wrong type for first argument");
1145
return NIL;
1146
}
1147
1148
/* Set documentation string? */
1149
if (2==argc) {
1150
sym_dbind(argv[0], obj_copy(argv[1], SHALLOW));
1151
return NIL;
1152
} else if (argc>2) {
1153
out_errorn("help: wrong number of arguments");
1154
return NIL;
1155
}
1156
1157
/* Obtain documentation string */
1158
assert(sym);
1159
is_run = !strcmp("run", obj_name(sym));
1160
doc = sym_dboundp(sym);
1161
if (sym!=argv[0]) obj_dest(sym);
1162
sym = NIL;
1163
1164
/* `help run' is a special case */
1165
if (!doc && is_run) {
1166
usage();
1167
return NIL;
1168
}
1169
1170
/* Print documentation */
1171
if (doc) {
1172
/* Turn off string formating -- use out_putw() instead */
1173
obj_t fmt_string = obj_new(C_SYM, "$fmt_string");
1174
obj_t old_fmt = sym_vboundp(fmt_string);
1175
sym_bi_set("$fmt_string", NULL, NULL, NULL);
1176
1177
/* Print documentation */
1178
obj_print(doc, OUT_STDOUT);
1179
out_nl(OUT_STDOUT);
1180
1181
/* Restore previous string format */
1182
sym_vbind(fmt_string, old_fmt);
1183
obj_dest(fmt_string);
1184
doc = obj_dest(doc);
1185
} else {
1186
out_errorn("help: no documentation found.");
1187
}
1188
return doc;
1189
}
1190
1191
/*---------------------------------------------------------------------------
1192
* Purpose: Cause subsequent input to come from the file named by the
1193
* argument. When that input source is exhausted then input
1194
* will begin to come from the original source again.
1195
*
1196
* Return: NIL
1197
*
1198
* Programmer: Robb Matzke
1199
* Monday, July 10, 2000
1200
*
1201
* Modifications:
1202
*---------------------------------------------------------------------------
1203
*/
1204
obj_t
1205
V_include(int argc, obj_t argv[])
1206
{
1207
char *name;
1208
lex_t *f;
1209
1210
if (1!=argc) {
1211
out_errorn("include: wrong number of arguments");
1212
return NIL;
1213
}
1214
if (NULL==(name=obj_name(argv[0]))) {
1215
out_errorn("include: no file name given");
1216
return NIL;
1217
}
1218
if (!LEX_STDIN) {
1219
out_errorn("include: internal error -- no input source");
1220
return NIL;
1221
}
1222
if (NULL==(f=lex_open(name))) return NULL;
1223
lex_push(LEX_STDIN, f);
1224
return NIL;
1225
}
1226
1227
1228
/*-------------------------------------------------------------------------
1229
* Function: F_length
1230
*
1231
* Purpose: Returns the number of elements in a list.
1232
*
1233
* Return: Success: Length of LST
1234
*
1235
* Failure: -1 if not a list, 0 if LST is NIL.
1236
*
1237
* Programmer: Robb Matzke
1238
* matzke@viper.llnl.gov
1239
* Dec 5 1996
1240
*
1241
* Modifications:
1242
*
1243
*-------------------------------------------------------------------------
1244
*/
1245
int
1246
F_length (obj_t lst) {
1247
1248
int i;
1249
1250
for (i=0; lst; lst=cons_tail(lst),i++) {
1251
if (C_CONS!=lst->pub.cls) return -1;
1252
}
1253
return i;
1254
}
1255
1256
1257
/*-------------------------------------------------------------------------
1258
* Function: V_list
1259
*
1260
* Purpose: Lists the current working directory in the specified
1261
* file. If no file is specified then `$1' is assumed.
1262
*
1263
* Return: Success: NIL
1264
*
1265
* Failure: NIL
1266
*
1267
* Programmer: Robb Matzke
1268
* matzke@viper.llnl.gov
1269
* Dec 4 1996
1270
*
1271
* Modifications:
1272
*
1273
* Robb Matzke, 3 Feb 1997
1274
* Cleaned up error messages.
1275
*
1276
* Robb Matzke, 6 Feb 1997
1277
* We list the objects ourselves instead of calling DBListDir because
1278
* it allows us to redirect and/or page the output. It also allows
1279
* us to make the output look more like the rest of the browser output.
1280
*
1281
* Robb Matzke, 7 Feb 1997
1282
* Now takes any number of arguments. If the first argument is
1283
* a symbol with a file value, then use that file for the listing.
1284
* If the first argument is not a symbol, then evaluate it to get the
1285
* file to use for listing. Otherwise treat the first argument as
1286
* an item to list. All other arguments are items to list.
1287
*
1288
* Robb Matzke, 25 Jul 1997
1289
* This function was indented to list the table of contents for the
1290
* current directory of a subset thereof. If object names and/or
1291
* wild cards are given, they apply to the names of the objects in the
1292
* current working directory. However, many people want to be able to
1293
* list the contents of a subdirectory by saying `ls dir1' where `dir1'
1294
* is a member of the current working directory. Therefore, after
1295
* wild-card expansion occurs, if the display list contains a single
1296
* object and that object is a directory, then we load the table of
1297
* contents from that directory and display it rather than the
1298
* directory name.
1299
*
1300
* Robb Matzke, 26 Aug 1997
1301
* Fixed a memory bug when the only argument is a directory name.
1302
*
1303
* Lisa J. Roberts, Mon Nov 22 17:27:53 PST 1999
1304
* I changed strdup to safe_strdup.
1305
*
1306
* Robb Matzke, 2000-05-17
1307
* If the argument is a directory name and that directory is empty
1308
* then the error message will be `ls: no table of contents' instead
1309
* of `ls: no matches'.
1310
*
1311
* Robb Matzke, 2000-07-03
1312
* If the first argument is a list of files then perform the
1313
* operation once for each file of that list.
1314
*-------------------------------------------------------------------------
1315
*/
1316
obj_t
1317
V_list (int argc, obj_t argv[])
1318
{
1319
obj_t fileobjs=NIL, ptr=NIL;
1320
int first_arg = 0;
1321
1322
if (argc>=1 && C_SYM==argv[0]->pub.cls) {
1323
/* Is the first symbol bound to a file or is it a special symbol
1324
* which evaluates to a file or list of files? */
1325
if ((fileobjs=sym_vboundp(argv[0]))) {
1326
if (C_FILE==fileobjs->pub.cls) {
1327
first_arg = 1;
1328
fileobjs = obj_new(C_CONS, fileobjs, NIL);
1329
} else {
1330
fileobjs = obj_dest(fileobjs);
1331
}
1332
} else if ((fileobjs=obj_eval(argv[0]))) {
1333
if (C_CONS==fileobjs->pub.cls) {
1334
first_arg = 1;
1335
} else {
1336
fileobjs = obj_dest(fileobjs);
1337
}
1338
}
1339
1340
} else if (argc>=1 && C_STR!=argv[0]->pub.cls) {
1341
/* The file is the result of evaluating the first expression. */
1342
fileobjs = obj_eval(argv[0]);
1343
if (!fileobjs) return NIL; /*error in eval*/
1344
if (C_FILE==fileobjs->pub.cls) {
1345
first_arg = 1;
1346
fileobjs = obj_new(C_CONS, fileobjs, NIL);
1347
} else {
1348
out_errorn("ls: arg-1 does not evaluate to a file");
1349
goto error;
1350
}
1351
}
1352
1353
/* Use the default file. */
1354
if (!fileobjs) {
1355
obj_t b1 = obj_new(C_SYM, "$1");
1356
fileobjs = sym_vboundp(b1);
1357
b1 = obj_dest(b1);
1358
1359
if (!fileobjs) {
1360
out_errorn("ls: no default open file (`$1' has no value)");
1361
return NIL;
1362
}
1363
fileobjs = obj_new(C_CONS, fileobjs, NIL);
1364
}
1365
1366
for (ptr=fileobjs; ptr; ptr=cons_tail(ptr)) {
1367
DBfile *file;
1368
toc_t *toc;
1369
int i, nentries, width, old_type=(-1);
1370
int argno, nprint;
1371
int *selected=NULL, last_selected=-1;
1372
char buf[256], *needle, nselected=0;
1373
char cwd[1024], *subdir;
1374
1375
/* Do we have a file? */
1376
obj_t fileobj = cons_head(ptr);
1377
if (!fileobj || C_FILE!=fileobj->pub.cls ||
1378
NULL==(file=file_file(fileobj))) {
1379
out_error("ls: inappropriate file: ", fileobj);
1380
goto error;
1381
}
1382
1383
/* Get the table of contents sorted first by object type and
1384
* then by object name. */
1385
toc = browser_DBGetToc(file, &nentries, sort_toc_by_type);
1386
if (!toc || 0==nentries) {
1387
out_errorn("ls: no table of contents");
1388
goto error;
1389
}
1390
1391
/* Prune the table of contents based on the arguments supplied. */
1392
selected = calloc(nentries, sizeof(int));
1393
if (first_arg==argc) {
1394
for (i=0; i<nentries; i++) selected[i] = true;
1395
} else {
1396
for (argno=first_arg; argno<argc; argno++) {
1397
if (NULL==(needle=obj_name(argv[argno]))) {
1398
out_errorn("ls: arg-%d is not an object name", argno+1);
1399
} else {
1400
#ifndef HAVE_FNMATCH
1401
if (strpbrk(needle, "*?[]")) {
1402
out_errorn("ls: arg-%d contains wildcards but your C "
1403
"library doesn't have the `fnmatch' "
1404
"function", argno+1);
1405
}
1406
#endif
1407
for (i=0; i<nentries; i++) {
1408
#ifdef HAVE_FNMATCH
1409
if (0==fnmatch(needle, toc[i].name,
1410
FNM_FILE_NAME|FNM_PERIOD)) {
1411
selected[i] = true;
1412
nselected++;
1413
last_selected = i;
1414
}
1415
#else
1416
if (!strcmp(toc[i].name, needle)) {
1417
selected[i] = true;
1418
nselected++;
1419
last_selected = i;
1420
}
1421
#endif
1422
}
1423
}
1424
}
1425
}
1426
1427
/* If the result is a single directory, then list the contents of
1428
* the directory instead of the directory name. */
1429
if (1==nselected && BROWSER_DB_DIR==toc[last_selected].type) {
1430
subdir = safe_strdup(toc[last_selected].name);
1431
for (i=0; i<nentries; i++) free(toc[i].name);
1432
free(toc);
1433
if (DBGetDir(file, cwd)<0) return NIL;
1434
if (DBSetDir(file, subdir)<0) return NIL;
1435
toc = browser_DBGetToc(file, &nentries, sort_toc_by_type);
1436
if (DBSetDir(file, cwd)<0) return NIL;
1437
if (!toc || 0==nentries) {
1438
out_errorn("ls: no table of contents");
1439
goto error;
1440
}
1441
out_info("Listing file: %s, directory: %s:",
1442
obj_name(fileobj), subdir);
1443
out_nl(OUT_STDOUT);
1444
free(subdir);
1445
subdir = NULL;
1446
1447
/* select all entries of that directory for display */
1448
free(selected);
1449
selected = calloc(nentries, sizeof(int));
1450
for (i=0; i<nentries; i++) selected[i] = true;
1451
} else {
1452
out_info("Listing from file %s", obj_name(fileobj));
1453
}
1454
1455
/* Find the widest entry and if any entries were even selected. */
1456
width = 0;
1457
for (i=0; i<nentries; i++) {
1458
if (selected[i]) width = MAX(width, strlen(toc[i].name));
1459
}
1460
if (0==width) {
1461
out_errorn("ls: no matches");
1462
}
1463
1464
/* Print the objects grouped by object type. Each group of objects
1465
* has a prefix only on the first line. */
1466
if (width>0) {
1467
for (i=nprint=0; i<nentries && !out_brokenpipe(OUT_STDOUT); i++) {
1468
if (!selected[i]) continue;
1469
if (toc[i].type!=old_type) {
1470
if (nprint) {
1471
out_nl(OUT_STDOUT);
1472
out_nl(OUT_STDOUT);
1473
}
1474
sprintf(buf, "%s(s)", ObjTypeName[toc[i].type]);
1475
out_push(OUT_STDOUT, buf);
1476
}
1477
out_printf(OUT_STDOUT, " %-*s", width, toc[i].name);
1478
if (toc[i].type!=old_type) {
1479
out_pop(OUT_STDOUT);
1480
old_type = toc[i].type;
1481
}
1482
nprint++;
1483
}
1484
out_nl(OUT_STDOUT);
1485
}
1486
1487
/* Free data */
1488
for (i=0; i<nentries; i++) free(toc[i].name);
1489
free(toc);
1490
free(selected);
1491
}
1492
return NIL;
1493
1494
error:
1495
obj_dest(fileobjs);
1496
return NIL;
1497
}
1498
1499
1500
/*-------------------------------------------------------------------------
1501
* Function: V_make_list
1502
*
1503
* Purpose: Returns a list of the arguments. The list is not the
1504
* same list as the original arguments since the arguments
1505
* have been evaluated.
1506
*
1507
* Return: Success: Ptr to a new list with shallow copies of
1508
* the caller-evaluated arguments
1509
*
1510
* Failure: NIL
1511
*
1512
* Programmer: Robb Matzke
1513
* robb@maya.nuance.mdn.com
1514
* Apr 2 1997
1515
*
1516
* Modifications:
1517
*
1518
*-------------------------------------------------------------------------
1519
*/
1520
obj_t
1521
V_make_list (int argc, obj_t argv[]) {
1522
1523
obj_t opstack=NIL, retval=NIL;
1524
int i;
1525
1526
for (i=0; i<argc; i++) {
1527
opstack = obj_new (C_CONS,
1528
obj_copy (argv[i], SHALLOW),
1529
opstack);
1530
}
1531
retval = F_reverse (opstack);
1532
opstack = obj_dest (opstack);
1533
return retval;
1534
}
1535
1536
1537
/*-------------------------------------------------------------------------
1538
* Function: V_noprint
1539
*
1540
* Purpose: Returns NIL. Used to suppress the output of a non-nil
1541
* expression.
1542
*
1543
* Return: Success: NIL
1544
*
1545
* Failure: NIL
1546
*
1547
* Programmer: Robb Matzke
1548
* robb@maya.nuance.mdn.com
1549
* Jan 23 1997
1550
*
1551
* Modifications:
1552
*
1553
*-------------------------------------------------------------------------
1554
*/
1555
/*ARGSUSED*/
1556
obj_t
1557
V_noprint (int argc, obj_t argv[]) {
1558
1559
return NIL;
1560
}
1561
1562
1563
/*-------------------------------------------------------------------------
1564
* Function: V_open
1565
*
1566
* Purpose: Sets the current file to be the named SILO file. The
1567
* current file is called `$1'. If an even number of
1568
* arguments are present then the first argument of each pair
1569
* is the name of a SILO file and the second argument is the
1570
* name of the variable that will hold that file.
1571
*
1572
* Return: Success: NIL
1573
*
1574
* Failure: NIL
1575
*
1576
* Programmer: Robb Matzke
1577
* matzke@viper.llnl.gov
1578
* Dec 4 1996
1579
*
1580
* Modifications:
1581
*
1582
* Robb Matzke, 3 Feb 1997
1583
* Changed the name displayed in error messages to `open' since
1584
* this function is usually invoked with the `open' command.
1585
*
1586
* Robb Matzke, 6 Feb 1997
1587
* The previous file is closed even if the new file can't be opened.
1588
*
1589
* Robb Matzke, 7 Feb 1997
1590
* Takes just one or two arguments. Changed the name of this function
1591
* from V_with to V_open.
1592
*
1593
*-------------------------------------------------------------------------
1594
*/
1595
obj_t
1596
V_open (int argc, obj_t argv[]) {
1597
1598
obj_t file=NIL, filename=NIL, var=NIL;
1599
1600
/*
1601
* Get the variable name
1602
*/
1603
if (2==argc) {
1604
filename = obj_copy (argv[0], SHALLOW);
1605
var = obj_copy (argv[1], SHALLOW);
1606
} else if (1==argc) {
1607
filename = obj_copy (argv[0], SHALLOW);
1608
var = obj_new (C_SYM, "$1");
1609
} else {
1610
out_errorn ("open: wrong number of arguments");
1611
goto error;
1612
}
1613
1614
if (C_SYM!=var->pub.cls) {
1615
out_errorn ("open: arg-2 should be a symbol");
1616
goto error;
1617
}
1618
1619
/*
1620
* Open the file.
1621
*/
1622
if (Verbosity>=1) {
1623
char *ascii_name = obj_name (filename);
1624
out_info ("opening `%s' as %s",
1625
ascii_name?ascii_name:"***NO NAME***", obj_name (var));
1626
}
1627
file = V_file (1, &filename);
1628
if (!file) {
1629
sym_vbind (var, NIL);
1630
goto error;
1631
}
1632
1633
/*
1634
* Assign the file to the variable.
1635
*/
1636
sym_vbind (var, file);
1637
var = obj_dest (var);
1638
file = NIL ; /*do not destroy file*/
1639
return NIL;
1640
1641
error:
1642
if (file ) file = obj_dest (file );
1643
if (var ) var = obj_dest (var );
1644
if (filename) filename = obj_dest (filename);
1645
return NIL;
1646
}
1647
1648
1649
/*-------------------------------------------------------------------------
1650
* Function: V_pipe
1651
*
1652
* Purpose: Evaluates and prints the first argument with standard output
1653
* redirected to the shell command specified by the second
1654
* argument.
1655
*
1656
* Return: Success: NIL
1657
*
1658
* Failure: NIL
1659
*
1660
* Programmer: Robb Matzke
1661
* robb@maya.nuance.mdn.com
1662
* Jan 13 1997
1663
*
1664
* Modifications:
1665
*
1666
* Robb Matzke, 3 Feb 1997
1667
* Cleaned up error messages.
1668
*
1669
*-------------------------------------------------------------------------
1670
*/
1671
obj_t
1672
V_pipe (int argc, obj_t argv[]) {
1673
1674
out_t saved;
1675
FILE *f;
1676
char *command, *fmode;
1677
obj_t out=NIL;
1678
int status;
1679
1680
1681
if (3!=argc) {
1682
out_errorn ("Pipe: wrong number of arguments");
1683
return NIL;
1684
}
1685
if (NULL==(command=obj_name(argv[1]))) {
1686
out_error ("Pipe: arg-2 (command) is inappropriate: ", argv[1]);
1687
return NIL;
1688
}
1689
if (NULL==(fmode=obj_name(argv[2]))) {
1690
out_error ("Pipe: arg-3 (mode) is inappropriate: ", argv[2]);
1691
return NIL;
1692
}
1693
if (NULL==(f=popen(command, fmode))) {
1694
out_errorn ("Pipe: could not run: %s", command);
1695
return NIL;
1696
}
1697
1698
/*
1699
* Point OUT_STDOUT at the pipe.
1700
*/
1701
fflush (stderr);
1702
fflush (stdout);
1703
saved = *OUT_STDOUT;
1704
out_reset (OUT_STDOUT);
1705
OUT_STDOUT->f = f;
1706
OUT_STDOUT->paged = false;
1707
1708
/*
1709
* Evaluate the first argument.
1710
*/
1711
out = obj_eval (argv[0]);
1712
if (out || Verbosity>=2) {
1713
obj_print (out, OUT_STDOUT);
1714
out_nl (OUT_STDOUT);
1715
}
1716
out = obj_dest (out);
1717
1718
/*
1719
* Point OUT_STDOUT at the original stream.
1720
*/
1721
*OUT_STDOUT = saved;
1722
1723
/*
1724
* Close the command
1725
*/
1726
status = pclose (f);
1727
if (WIFEXITED(status)) {
1728
if (WEXITSTATUS(status)) {
1729
out_errorn ("Pipe: command failed with exit status: %d",
1730
WEXITSTATUS(status));
1731
}
1732
} else if (WIFSIGNALED(status)) {
1733
out_errorn ("Pipe: command received signal %d", WTERMSIG(status));
1734
}
1735
1736
return NIL;
1737
}
1738
1739
1740
/*-------------------------------------------------------------------------
1741
* Function: V_pointer
1742
*
1743
* Purpose: Creates a pointer to the first argument.
1744
*
1745
* Return: Success: Pointer type object.
1746
*
1747
* Failure: NIL
1748
*
1749
* Programmer: Robb Matzke
1750
* robb@callisto.nuance.mdn.com
1751
* Dec 9, 1996
1752
*
1753
* Modifications:
1754
*
1755
*-------------------------------------------------------------------------
1756
*/
1757
obj_t
1758
V_pointer (int argc, obj_t argv[]) {
1759
1760
if (1!=argc) {
1761
out_errorn ("pointer: wrong number of arguments");
1762
return NIL;
1763
}
1764
return obj_new (C_PTR, obj_copy (argv[0], SHALLOW));
1765
}
1766
1767
1768
/*-------------------------------------------------------------------------
1769
* Function: V_primitive
1770
*
1771
* Purpose: Given the name of a primitive type, return a new
1772
* primitive type object.
1773
*
1774
* Return: Success: Primitive type object.
1775
*
1776
* Failure: NIL
1777
*
1778
* Programmer: Robb Matzke
1779
* matzke@viper.llnl.gov
1780
* Dec 5 1996
1781
*
1782
* Modifications:
1783
*
1784
*-------------------------------------------------------------------------
1785
*/
1786
obj_t
1787
V_primitive (int argc, obj_t argv[]) {
1788
1789
char *s, buf[32];
1790
1791
if (1!=argc) {
1792
out_errorn ("primitive: wrong number of arguments");
1793
return NIL;
1794
}
1795
1796
if (num_isint(argv[0])) {
1797
sprintf (buf, "%d", num_int(argv[0]));
1798
s = buf;
1799
} else if (NULL==(s=obj_name(argv[0]))) {
1800
out_error ("primitive: type name is inappropriate: ", argv[0]);
1801
return NIL;
1802
}
1803
1804
return obj_new (C_PRIM, s);
1805
}
1806
1807
1808
/*-------------------------------------------------------------------------
1809
* Function: V_print
1810
*
1811
* Purpose: Prints each argument to standard output.
1812
*
1813
* Return: Success: NIL
1814
*
1815
* Failure: NIL
1816
*
1817
* Programmer: Robb Matzke
1818
* matzke@viper.llnl.gov
1819
* Dec 4 1996
1820
*
1821
* Modifications:
1822
*
1823
* Robb Matzke, 3 Feb 1997
1824
* NIL arguments are ignored. We do this because a command like `XXX'
1825
* is parsed as `print XXX' and if `XXX' is not an object we get an
1826
* error message and the `XXX' turns into a NIL pointer. Printing
1827
* `nil' would be redundant. However, this means that the command
1828
* `print nil' won't do anything!
1829
*
1830
*-------------------------------------------------------------------------
1831
*/
1832
obj_t
1833
V_print (int argc, obj_t argv[]) {
1834
1835
int i;
1836
1837
for (i=0; i<argc && !out_brokenpipe(OUT_STDOUT); i++) {
1838
if (argv[i]) {
1839
obj_print (argv[i], OUT_STDOUT);
1840
out_nl (OUT_STDOUT);
1841
}
1842
}
1843
return NIL;
1844
}
1845
1846
1847
/*-------------------------------------------------------------------------
1848
* Function: V_pwd
1849
*
1850
* Purpose: Prints the current working directory of the specified file,
1851
* or `$1' if no file is specified. Actually, this function
1852
* doesn't really do anything but return the file, since the
1853
* print form of a file includes the current working
1854
* directory name.
1855
*
1856
* Return: Success: NIL
1857
*
1858
* Failure: NIL
1859
*
1860
* Programmer: Robb Matzke
1861
* robb@maya.nuance.mdn.com
1862
* Jan 20 1997
1863
*
1864
* Modifications:
1865
* Robb Matzke, 3 Feb 1997
1866
* Cleaned up error messages.
1867
*
1868
* Robb Matzke, 2000-07-03
1869
* If invoked with a single argument which is a list of files
1870
* just return that list of files. This allows us to invoke
1871
* this command as `pwd $*' to show the current working
1872
* directories of all the command-line files.
1873
*-------------------------------------------------------------------------
1874
*/
1875
obj_t
1876
V_pwd (int argc, obj_t argv[])
1877
{
1878
obj_t retval=NIL;
1879
1880
if (0==argc) {
1881
obj_t name = obj_new(C_SYM, "$1");
1882
retval = sym_vboundp(name);
1883
name = obj_dest(name);
1884
if (!retval) {
1885
out_errorn("pwd: no default open file (`$1' has no value)");
1886
goto error;
1887
}
1888
} else if (1==argc) {
1889
retval = obj_copy(argv[0], SHALLOW);
1890
} else {
1891
out_errorn("pwd: wrong number of arguments");
1892
goto error;
1893
}
1894
1895
if (!retval) {
1896
out_errorn("pwd: no file specified");
1897
goto error;
1898
} else if (C_CONS==retval->pub.cls) {
1899
obj_t ptr, f;
1900
for (ptr=retval; ptr; ptr=cons_tail(ptr)) {
1901
f = cons_head(ptr);
1902
if (!f || C_FILE!=f->pub.cls) {
1903
out_errorn("pwd: arg is not a list of files");
1904
goto error;
1905
}
1906
}
1907
} else if (C_FILE!=retval->pub.cls) {
1908
out_errorn("pwd: argument is not a file");
1909
goto error;
1910
}
1911
1912
return retval;
1913
1914
error:
1915
obj_dest(retval);
1916
return NIL;
1917
}
1918
1919
1920
/*-------------------------------------------------------------------------
1921
* Function: V_quote
1922
*
1923
* Purpose: Just returns a copy of the first argument. If there's more
1924
* than one argument then return a list of the arguments.
1925
*
1926
* Return: Success: A copy of the first argument.
1927
*
1928
* Failure: NIL
1929
*
1930
* Programmer: Robb Matzke
1931
* robb@maya.nuance.mdn.com
1932
* Apr 2 1997
1933
*
1934
* Modifications:
1935
*
1936
*-------------------------------------------------------------------------
1937
*/
1938
obj_t
1939
V_quote (int argc, obj_t argv[]) {
1940
1941
if (argc<1) return NIL;
1942
if (1==argc) return obj_copy (argv[0], SHALLOW);
1943
return V_make_list (argc, argv);
1944
}
1945
1946
1947
/*-------------------------------------------------------------------------
1948
* Function: V_redirect
1949
*
1950
* Purpose: Redirects standard output to the specified file then evaluates
1951
* and prints the first argument. The file name is the
1952
* second argument.
1953
*
1954
* Return: Success: NIL
1955
*
1956
* Failure: NIL
1957
*
1958
* Programmer: Robb Matzke
1959
* matzke@viper.llnl.gov
1960
* Dec 4 1996
1961
*
1962
* Modifications:
1963
*
1964
* Robb Matzke, 3 Feb 1997
1965
* Cleaned up error messages.
1966
*
1967
* Thomas R. Treadway, Tue Jun 27 13:59:21 PDT 2006
1968
* Added HAVE_STRERROR wrapper
1969
*
1970
*-------------------------------------------------------------------------
1971
*/
1972
obj_t
1973
V_redirect (int argc, obj_t argv[]) {
1974
1975
out_t saved;
1976
FILE *f;
1977
obj_t out=NIL;
1978
char *fname=NULL, *fmode=NULL;
1979
1980
if (3!=argc) {
1981
out_errorn ("Redirect: wrong number of arguments");
1982
return NIL;
1983
}
1984
if (!argv[1] || NULL==(fname=obj_name(argv[1]))) {
1985
out_error ("Redirect: arg-2 (file name) is inappropriate", argv[1]);
1986
return NIL;
1987
}
1988
if (!argv[2] || NULL==(fmode=obj_name(argv[2]))) {
1989
out_error ("Redirect: arg-3 (mode) is inappropriate", argv[2]);
1990
return NIL;
1991
}
1992
if (NULL==(f=fopen(fname, fmode))) {
1993
#ifdef HAVE_STRERROR
1994
out_errorn ("Redirect: cannot open `%s' (%s)",
1995
fname, strerror(errno));
1996
#else
1997
out_errorn ("Redirect: cannot open `%s' (errno=%d)",
1998
fname, errno);
1999
#endif
2000
return NIL;
2001
}
2002
2003
2004
fflush (stderr);
2005
fflush (stdout);
2006
saved = *OUT_STDOUT;
2007
out_reset (OUT_STDOUT);
2008
OUT_STDOUT->f = f;
2009
OUT_STDOUT->paged = false;
2010
2011
out = obj_eval (argv[0]);
2012
if (out || Verbosity>=2) {
2013
obj_print (out, OUT_STDOUT);
2014
out_nl (OUT_STDOUT);
2015
}
2016
out = obj_dest (out);
2017
2018
*OUT_STDOUT = saved;
2019
fclose (f);
2020
2021
return NIL;
2022
}
2023
2024
2025
/*-------------------------------------------------------------------------
2026
* Function: F_reverse
2027
*
2028
* Purpose: Reverses list LST.
2029
*
2030
* Return: Success: Ptr to a new list.
2031
*
2032
* Failure: NIL
2033
*
2034
* Programmer: Robb Matzke
2035
* matzke@viper.llnl.gov
2036
* Dec 4 1996
2037
*
2038
* Modifications:
2039
*
2040
*-------------------------------------------------------------------------
2041
*/
2042
obj_t
2043
F_reverse (obj_t lst) {
2044
2045
obj_t ret=NIL, b1, b2;
2046
2047
if (!lst) return NIL;
2048
if (C_CONS!=lst->pub.cls) return obj_copy(lst, SHALLOW);
2049
2050
for (/*void*/; lst; lst=cons_tail(lst)) {
2051
2052
b1 = F_head (lst);
2053
b2 = F_cons (b1, ret);
2054
obj_dest (b1);
2055
obj_dest (ret);
2056
ret = b2;
2057
}
2058
return ret;
2059
}
2060
2061
2062
/*-------------------------------------------------------------------------
2063
* Function: V_setcwd
2064
*
2065
* Purpose: Sets the current working directory for a file (or for `$1'
2066
* if no file is specified).
2067
*
2068
* Return: Success: The file.
2069
*
2070
* Failure: NIL
2071
*
2072
* Programmer: Robb Matzke
2073
* robb@maya.nuance.mdn.com
2074
* Jan 20 1997
2075
*
2076
* Modifications:
2077
* Robb Matzke, 3 Feb 1997
2078
* Cleaned up error messages.
2079
*
2080
* Robb Matzke, 5 Feb 1997
2081
* The first argument is always the directory name. The second
2082
* argument is the optional file.
2083
*
2084
* Robb Matzke, 2000-07-03
2085
* If the second argument is a list of files (instead of just a file)
2086
* then the current working directory is changed for all listed files
2087
* and the file list is returned. The return value is always the list
2088
* of files, even if something goes wrong (this allows the user to see
2089
* what the CWD is for each file).
2090
*-------------------------------------------------------------------------
2091
*/
2092
obj_t
2093
V_setcwd (int argc, obj_t argv[])
2094
{
2095
obj_t files=NIL, cwd=NIL, ptr=NIL;
2096
char *dirname=NULL;
2097
DBfile *dbfile;
2098
2099
/* Get arguments */
2100
if (1==argc) {
2101
obj_t name = obj_new (C_SYM, "$1");
2102
files = sym_vboundp (name);
2103
name = obj_dest (name);
2104
cwd = argv[0];
2105
2106
if (!files) {
2107
out_errorn ("cd: no default open file (`$1' has no value)");
2108
return NIL;
2109
}
2110
} else if (2==argc) {
2111
files = obj_copy (argv[1], SHALLOW);
2112
cwd = argv[0];
2113
} else {
2114
out_errorn ("cd: wrong number of arguments");
2115
return NIL;
2116
}
2117
2118
/* Make sure `files' is a list of files and the directory name is some
2119
* name string. */
2120
if (C_CONS!=files->pub.cls) {
2121
files = obj_new(C_CONS, files, NIL);
2122
}
2123
if (!cwd || NULL==(dirname=obj_name(cwd))) {
2124
out_error ("cd: inappropriate directory name: ", cwd);
2125
goto error;
2126
}
2127
2128
/* Change directories for each file */
2129
for (ptr=files; ptr; ptr=cons_tail(ptr)) {
2130
obj_t f = cons_head(ptr);
2131
if (!f || C_FILE!=f->pub.cls || NULL==(dbfile=file_file(f))) {
2132
out_error("cd: inappropriate file: ", f);
2133
} else if (DBSetDir (dbfile, dirname)<0) {
2134
out_errorn ("cd: cannot set CWD to \"%s\" for file %s",
2135
dirname, obj_name(f));
2136
}
2137
}
2138
2139
return files;
2140
2141
error:
2142
obj_dest(files);
2143
return NIL;
2144
}
2145
2146
2147
/*-------------------------------------------------------------------------
2148
* Function: V_setf
2149
*
2150
* Purpose: Sets the symbols functional value (and removes an
2151
* existing value).
2152
*
2153
* Return: Success: NIL
2154
*
2155
* Failure: NIL
2156
*
2157
* Programmer: Robb Matzke
2158
* robb@maya.nuance.mdn.com
2159
* Jan 21 1997
2160
*
2161
* Modifications:
2162
*
2163
* Robb Matzke, 3 Feb 1997
2164
* Cleaned up error messages.
2165
*
2166
*-------------------------------------------------------------------------
2167
*/
2168
obj_t
2169
V_setf (int argc, obj_t argv[]) {
2170
2171
if (2!=argc) {
2172
out_errorn ("fsetf: wrong number of arguments");
2173
return NIL;
2174
}
2175
if (!argv[0] || C_SYM!=argv[0]->pub.cls) {
2176
out_error ("fsetf: arg-1 (symbol) is inappropriate: ", argv[0]);
2177
return NIL;
2178
}
2179
2180
sym_fbind (argv[0], obj_copy(argv[1], SHALLOW));
2181
return NIL;
2182
}
2183
2184
2185
/*-------------------------------------------------------------------------
2186
* Function: V_struct
2187
*
2188
* Purpose: Creates a structure. The first argument is the name
2189
* and the remaining arguments are offset and subtype pairs.
2190
*
2191
* Return: Success: Ptr to a struct type object.
2192
*
2193
* Failure: NIL
2194
*
2195
* Programmer: Robb Matzke
2196
* matzke@viper.llnl.gov
2197
* Dec 6 1996
2198
*
2199
* Modifications:
2200
*
2201
*-------------------------------------------------------------------------
2202
*/
2203
obj_t
2204
V_struct (int argc, obj_t argv[]) {
2205
2206
obj_t sub[32];
2207
int offset[32], i, argno;
2208
char *structname, *name[32];
2209
2210
if (argc<4 || argc>NELMTS(sub)*3+1) {
2211
out_errorn ("struct: wrong number of arguments");
2212
return NIL;
2213
}
2214
2215
memset (sub, 0, sizeof(sub));
2216
memset (offset, 0, sizeof(offset));
2217
memset (name, 0, sizeof(name));
2218
2219
structname = obj_name (argv[0]);
2220
2221
for (i=0,argno=1; i<NELMTS(sub) && argno+1<argc; i++,argno+=3) {
2222
/*
2223
* The offset.
2224
*/
2225
if (!argv[argno] || C_NUM!=argv[argno]->pub.cls) {
2226
out_errorn ("struct: offset for component %d is not numeric", i+1);
2227
return NIL;
2228
}
2229
if ((offset[i]=num_int(argv[argno]))<0) {
2230
out_errorn ("struct: offset for component %d is out of range", i+1);
2231
return NIL;
2232
}
2233
2234
/*
2235
* The name.
2236
*/
2237
if (NULL==(name[i]=obj_name(argv[argno+1]))) {
2238
out_errorn ("struct: component %d has no name", i+1);
2239
return NIL;
2240
}
2241
2242
/*
2243
* The component type.
2244
*/
2245
sub[i] = argv[argno+2];
2246
if (!sub[i]) {
2247
out_errorn ("struct: component type %d is missing", i+1);
2248
return NIL;
2249
}
2250
}
2251
2252
return obj_new (C_STC, structname,
2253
obj_copy(sub[ 0], SHALLOW), offset[ 0], name[ 0],
2254
obj_copy(sub[ 1], SHALLOW), offset[ 1], name[ 1],
2255
obj_copy(sub[ 2], SHALLOW), offset[ 2], name[ 2],
2256
obj_copy(sub[ 3], SHALLOW), offset[ 3], name[ 3],
2257
obj_copy(sub[ 4], SHALLOW), offset[ 4], name[ 4],
2258
obj_copy(sub[ 5], SHALLOW), offset[ 5], name[ 5],
2259
obj_copy(sub[ 6], SHALLOW), offset[ 6], name[ 6],
2260
obj_copy(sub[ 7], SHALLOW), offset[ 7], name[ 7],
2261
obj_copy(sub[ 8], SHALLOW), offset[ 8], name[ 8],
2262
obj_copy(sub[ 9], SHALLOW), offset[ 9], name[ 9],
2263
obj_copy(sub[10], SHALLOW), offset[10], name[10],
2264
obj_copy(sub[11], SHALLOW), offset[11], name[11],
2265
obj_copy(sub[12], SHALLOW), offset[12], name[12],
2266
obj_copy(sub[13], SHALLOW), offset[13], name[13],
2267
obj_copy(sub[14], SHALLOW), offset[14], name[14],
2268
obj_copy(sub[15], SHALLOW), offset[15], name[15],
2269
obj_copy(sub[16], SHALLOW), offset[16], name[16],
2270
obj_copy(sub[17], SHALLOW), offset[17], name[17],
2271
obj_copy(sub[18], SHALLOW), offset[18], name[18],
2272
obj_copy(sub[19], SHALLOW), offset[19], name[19],
2273
obj_copy(sub[20], SHALLOW), offset[20], name[20],
2274
obj_copy(sub[21], SHALLOW), offset[21], name[21],
2275
obj_copy(sub[22], SHALLOW), offset[22], name[22],
2276
obj_copy(sub[23], SHALLOW), offset[23], name[23],
2277
obj_copy(sub[24], SHALLOW), offset[24], name[24],
2278
obj_copy(sub[25], SHALLOW), offset[25], name[25],
2279
obj_copy(sub[26], SHALLOW), offset[26], name[26],
2280
obj_copy(sub[27], SHALLOW), offset[27], name[27],
2281
obj_copy(sub[28], SHALLOW), offset[28], name[28],
2282
obj_copy(sub[29], SHALLOW), offset[29], name[29],
2283
obj_copy(sub[30], SHALLOW), offset[30], name[30],
2284
obj_copy(sub[31], SHALLOW), offset[31], name[31], NULL);
2285
}
2286
2287
2288
/*-------------------------------------------------------------------------
2289
* Function: F_tail
2290
*
2291
* Purpose: Returns the tail of a list.
2292
*
2293
* Return: Success: Ptr to the tail
2294
*
2295
* Failure: NIL
2296
*
2297
* Programmer: Robb Matzke
2298
* matzke@viper.llnl.gov
2299
* Dec 4 1996
2300
*
2301
* Modifications:
2302
*
2303
*-------------------------------------------------------------------------
2304
*/
2305
obj_t
2306
F_tail (obj_t lst) {
2307
2308
if (!lst) return NIL;
2309
if (C_CONS!=lst->pub.cls) return NIL;
2310
2311
return obj_copy (cons_tail(lst), SHALLOW);
2312
}
2313
2314
2315
/*-------------------------------------------------------------------------
2316
* Function: V_typeof
2317
*
2318
* Purpose: Prints the type of some object.
2319
*
2320
* Return: Success: The type
2321
*
2322
* Failure: NIL
2323
*
2324
* Programmer: Robb Matzke
2325
* robb@maya.nuance.mdn.com
2326
* Jan 6 1997
2327
*
2328
* Modifications:
2329
*
2330
* Robb Matzke, 3 Feb 1997
2331
* Works for all types of objects.
2332
*
2333
*-------------------------------------------------------------------------
2334
*/
2335
obj_t
2336
V_typeof (int argc, obj_t argv[]) {
2337
2338
obj_t retval=NIL;
2339
char buf[256];
2340
2341
if (1!=argc) {
2342
out_errorn ("typeof: wrong number of arguments");
2343
return NIL;
2344
}
2345
2346
if (!argv[0]) {
2347
retval = NIL;
2348
2349
} else if (C_SDO==argv[0]->pub.cls) {
2350
retval = obj_copy (sdo_typeof(argv[0]), SHALLOW);
2351
2352
} else if (num_isint(argv[0])) {
2353
sprintf (buf, "%s_int", argv[0]->pub.cls->name);
2354
retval = obj_new (C_SYM, buf);
2355
2356
} else if (num_isfp(argv[0])) {
2357
sprintf (buf, "%s_fp", argv[0]->pub.cls->name);
2358
retval = obj_new (C_SYM, buf);
2359
2360
} else {
2361
retval = obj_new (C_SYM, argv[0]->pub.cls->name);
2362
2363
}
2364
return retval;
2365
}
2366
Loggerhead is a web-based interface for Breezy
Version: 2.0.1