1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
2-- All rights reserved.
3--
4-- Redistribution and use in source and binary forms, with or without
5-- modification, are permitted provided that the following conditions are
6-- met:
7--
8--     - Redistributions of source code must retain the above copyright
9--       notice, this list of conditions and the following disclaimer.
10--
11--     - Redistributions in binary form must reproduce the above copyright
12--       notice, this list of conditions and the following disclaimer in
13--       the documentation and/or other materials provided with the
14--       distribution.
15--
16--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
17--       names of its contributors may be used to endorse or promote products
18--       derived from this software without specific prior written permission.
19--
20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31
32)package "BOOT"
33
34-- This file contains the BOOT code for the FriCAS system command
35-- and synonym processing facility.  The code for )trace is in the file
36-- TRACE BOOT.  The list of system commands is $SYSCOMMANDS which is
37-- initialized in SETQ LISP.
38
39--% Utility Variable Initializations
40
41DEFPARAMETER($compileRecurrence, true)
42
43DEFPARAMETER($SYSCOMMANDS, [first x for x in $systemCommands])
44
45
46DEFPARAMETER($whatOptions, '( _
47    operations _
48    categories _
49    domains _
50    packages _
51    commands _
52    synonyms _
53    things _
54    ))
55
56DEFPARAMETER($clearOptions, '( _
57  modes _
58  operations _
59  properties _
60  types _
61  values  _
62  ))
63
64DEFPARAMETER($displayOptions, '( _
65  abbreviations _
66  all _
67  macros _
68  modes _
69  names _
70  operations  _
71  properties _
72  types _
73  values _
74  ))
75
76DEFPARAMETER($countAssoc, '( (cache countCache) ))
77
78--% Top level system command
79
80initializeSystemCommands() ==
81  l := $systemCommands
82  $SYSCOMMANDS := NIL
83  while l repeat
84    $SYSCOMMANDS := CONS(CAAR l, $SYSCOMMANDS)
85    l := rest l
86  $SYSCOMMANDS := NREVERSE $SYSCOMMANDS
87
88systemCommand [[op,:argl],:options] ==
89  $options: local:= options
90  $e:local := $CategoryFrame
91  fun := selectOptionLC(op,$SYSCOMMANDS,'commandError)
92  argl and (argl.0 = '_?) and fun ~= 'synonym =>
93    helpSpad2Cmd [fun]
94  fun := selectOption(fun,commandsForUserLevel $systemCommands,
95    'commandUserLevelError)
96  FUNCALL(fun, argl)
97
98commandsForUserLevel l == --[a for [a,:b] in l | satisfiesUserLevel(a)]
99  c := nil
100  for [a,:b] in l repeat
101    satisfiesUserLevel b => c := [a,:c]
102  reverse c
103
104synonymsForUserLevel l ==
105  -- l is a list of synonyms, and this returns a sublist of applicable
106  -- synonyms at the current user level.
107  $UserLevel = 'development => l
108  nl := NIL
109  for syn in reverse l repeat
110    cmd := STRING2ID_N(rest(syn), 1)
111    null selectOptionLC(cmd,commandsForUserLevel
112      $systemCommands,NIL) => nil
113    nl := [syn,:nl]
114  nl
115
116satisfiesUserLevel x ==
117  x          = 'interpreter => true
118  $UserLevel = 'interpreter => false
119  x          = 'compiler    => true
120  $UserLevel = 'compiler    => false
121  true
122
123unAbbreviateKeyword x ==
124  x' :=selectOptionLC(x,$SYSCOMMANDS,'commandErrorIfAmbiguous)
125  if not x' then
126    x' := 'system
127    SETQ(LINE, CONCAT('")system ", SUBSTRING(LINE, 1, #LINE-1)))
128    $currentLine := LINE
129  selectOption(x',commandsForUserLevel $systemCommands,
130    'commandUserLevelError)
131
132hasOption(al,opt) ==
133  optPname:= PNAME opt
134  found := NIL
135  for pair in al while not found repeat
136    stringPrefix?(PNAME first pair, optPname) => found := pair
137  found
138
139selectOptionLC(x,l,errorFunction) ==
140  selectOption(DOWNCASE object2Identifier x,l,errorFunction)
141
142selectOption(x,l,errorFunction) ==
143  member(x,l) => x                   --exact spellings are always OK
144  null IDENTP x =>
145    errorFunction => FUNCALL(errorFunction,x,u)
146    nil
147  u := [y for y in l | stringPrefix?(PNAME x,PNAME y)]
148  u is [y] => y
149  errorFunction => FUNCALL(errorFunction,x,u)
150  nil
151
152terminateSystemCommand() ==
153    FRESH_-LINE()
154    TOK := 'END_UNIT
155    throw_to_reader()
156
157commandUserLevelError(x,u) == userLevelErrorMessage("command",x,u)
158
159optionUserLevelError(x,u) == userLevelErrorMessage("option",x,u)
160
161userLevelErrorMessage(kind,x,u) ==
162  null u =>
163    sayKeyedMsg("S2IZ0007",[$UserLevel,kind])
164    terminateSystemCommand()
165  commandAmbiguityError(kind,x,u)
166
167commandError(x,u) == commandErrorMessage("command",x,u)
168
169optionError(x,u) == commandErrorMessage("option",x,u)
170
171commandErrorIfAmbiguous(x, u) ==
172  null u => nil
173  commandAmbiguityError("command", x, u)
174
175commandErrorMessage(kind,x,u) ==
176  null u =>
177    sayKeyedMsg("S2IZ0008",[kind,x])
178    terminateSystemCommand()
179  commandAmbiguityError(kind,x,u)
180
181commandAmbiguityError(kind,x,u) ==
182  sayKeyedMsg("S2IZ0009",[kind,x])
183  for a in u repeat sayMSG ['"     ",:bright a]
184  terminateSystemCommand()
185
186--% Utility for access to original command line
187
188getSystemCommandLine() ==
189  p := STRPOS('")",$currentLine,0,NIL)
190  line := if p then SUBSTRING($currentLine,p,NIL) else $currentLine
191  maxIndex:= MAXINDEX line
192  for i in 0..maxIndex while (line.i~=" ") repeat index:= i
193  if index=maxIndex then line := '""
194  else line := SUBSTRING(line,index+2,nil)
195  line
196
197------------ start of commands ------------------------------------------
198
199--% )abbreviations
200
201abbreviations l ==
202  ioHook("startSysCmd", "abbrev")
203  abbreviationsSpad2Cmd l
204  ioHook("endSysCmd", "abbrev")
205
206abbreviationsSpad2Cmd l ==
207  null l => helpSpad2Cmd '(abbreviations)
208  abopts := '(query domain category package remove)
209
210  quiet := nil
211  for [opt] in $options repeat
212    opt := selectOptionLC(opt,'(quiet),'optionError)
213    opt = 'quiet => quiet := true
214
215  l is [opt,:al] =>
216    key := opOf first al
217    type := selectOptionLC(opt,abopts,'optionError)
218    type is 'query =>
219      null al => listConstructorAbbreviations()
220      constructor := abbreviation?(key) => abbQuery(constructor)
221      abbQuery(key)
222    type is 'remove =>
223      DELDATABASE(key,'ABBREVIATION)
224    ODDP SIZE al => sayKeyedMsg("S2IZ0002",[type])
225    repeat
226      null al => return 'fromLoop
227      [a,b,:al] := al
228      mkUserConstructorAbbreviation(b,a,type)
229      SETDATABASE(b,'ABBREVIATION,a)
230      SETDATABASE(b,'CONSTRUCTORKIND,type)
231    null quiet =>
232      sayKeyedMsg("S2IZ0001",[a,type,opOf b])
233      nil
234  nil
235
236listConstructorAbbreviations() ==
237  x := UPCASE queryUserKeyedMsg("S2IZ0056",NIL)
238  MEMQ(STRING2ID_N(x, 1), '(Y YES)) =>
239    whatSpad2Cmd '(categories)
240    whatSpad2Cmd '(domains)
241    whatSpad2Cmd '(packages)
242  sayKeyedMsg("S2IZ0057",NIL)
243
244--% )cd
245
246cd(args) ==
247    dname :=
248        null(args) =>
249            TRIM_-DIRECTORY_-NAME(NAMESTRING(USER_-HOMEDIR_-PATHNAME()))
250        first(args)
251    if SYMBOLP(dname) then dname := SYMBOL_-NAME(dname)
252    CHDIR(dname)
253    sayKeyedMsg("S2IZ0070", [GET_-CURRENT_-DIRECTORY()])
254
255--% )clear
256
257clear l == clearSpad2Cmd l
258
259clearSpad2Cmd l ==
260  -- new version which changes the environment and updates history
261  $clearExcept: local := nil
262  if $options then $clearExcept :=
263    "and"/[selectOptionLC(opt,'(except),'optionError) =
264             'except for [opt,:.] in $options]
265  null l =>
266    optList:= "append"/[['%l,'"       ",x] for x in $clearOptions]
267    sayKeyedMsg("S2IZ0010",[optList])
268  arg := selectOptionLC(first l,'(all completely scaches),NIL)
269  arg = 'all          => clearCmdAll()
270  arg = 'completely   => clearCmdCompletely()
271  arg = 'scaches      => clear_sorted_caches()
272  $clearExcept => clearCmdExcept(l)
273  clearCmdParts(l)
274  updateCurrentInterpreterFrame()
275
276clearCmdCompletely() ==
277  clearCmdAll()
278  $localExposureData := COPY_-SEQ $localExposureDataDefault
279  sayKeyedMsg("S2IZ0013",NIL)
280  clearClams()
281  clearConstructorCaches()
282  sayKeyedMsg("S2IZ0014",NIL)
283  RECLAIM()
284  sayKeyedMsg("S2IZ0015",NIL)
285  NIL
286
287clearCmdAll() ==
288  clear_sorted_caches()
289  ------undo special variables------
290  $frameRecord := nil
291  $previousBindings := nil
292  untraceMapSubNames $trace_names
293  $InteractiveFrame := LIST LIST NIL
294  resetInCoreHist()
295  if $useInternalHistoryTable
296    then $internalHistoryTable := NIL
297    else deleteFile histFileName()
298  if not null $IOindex then $IOindex := 1
299  updateCurrentInterpreterFrame()
300  $currentLine := '")clear all"    --restored 3/94; needed for undo (RDJ)
301  clearMacroTable()
302  if $frameMessages then sayKeyedMsg("S2IZ0011",[$interpreterFrameName])
303  else sayKeyedMsg("S2IZ0012",NIL)
304
305clearCmdExcept(l is [opt,:vl]) ==
306  --clears elements of vl of all options EXCEPT opt
307  for option in $clearOptions |
308    not stringPrefix?(object2String opt,object2String option)
309      repeat clearCmdParts [option,:vl]
310
311clearCmdParts(l is [opt,:vl]) ==
312  -- clears the bindings indicated by opt of all variables in vl
313
314  option:= selectOptionLC(opt,$clearOptions,'optionError)
315  option:= INTERN PNAME option
316
317  -- the option can be plural but the key in the alist is sometimes
318  -- singular
319
320  option :=
321    option = 'types =>  'mode
322    option = 'modes =>  'mode
323    option = 'values => 'value
324    option
325
326  null vl => sayKeyedMsg("S2IZ0055",NIL)
327  pmacs := getParserMacroNames()
328  imacs := getInterpMacroNames()
329  if vl='(all) then
330    vl := ASSOCLEFT CAAR $InteractiveFrame
331    vl := REMDUP(append(vl, pmacs))
332  $e : local := $InteractiveFrame
333  for x in vl repeat
334    clearDependencies(x)
335    if option='properties and x in pmacs then clearParserMacro(x)
336    if option='properties and x in imacs and not (x in pmacs) then
337        sayMessage ['"   You cannot clear the definition of the system-defined macro ",
338            fixObjectForPrinting x,"."]
339    p1 := assoc(x,CAAR $InteractiveFrame) =>
340      option='properties =>
341        if isMap x then
342          (lm := get(x,'localModemap,$InteractiveFrame)) =>
343            PAIRP lm => untraceMapSubNames [CADAR lm]
344          NIL
345        for p2 in rest p1 repeat
346            prop := first p2
347            recordOldValue(x, prop, rest p2)
348            recordNewValue(x, prop, NIL)
349        SETF(CAAR $InteractiveFrame,deleteAssoc(x,CAAR $InteractiveFrame))
350      p2 := assoc(option, rest p1) =>
351        recordOldValue(x, option, rest p2)
352        recordNewValue(x,option,NIL)
353        RPLACD(p2,NIL)
354  nil
355
356--% )close
357
358queryClients () ==
359  -- Returns the number of active scratchpad clients
360  sockSendInt($SessionManager, $QueryClients)
361  sockGetInt $SessionManager
362
363
364close args ==
365  quiet:local:= false
366  null $SpadServer =>
367    throwKeyedMsg("S2IZ0071", [])
368  numClients := queryClients()
369  numClients > 1 =>
370    sockSendInt($SessionManager, $CloseClient)
371    sockSendInt($SessionManager, $currentFrameNum)
372    closeInterpreterFrame(NIL)
373  for [opt,:.] in $options repeat
374    fullopt := selectOptionLC(opt, '(quiet), 'optionError)
375    fullopt = 'quiet   =>
376           quiet:=true
377  quiet =>
378    sockSendInt($SessionManager, $CloseClient)
379    sockSendInt($SessionManager, $currentFrameNum)
380    closeInterpreterFrame(NIL)
381  x := UPCASE queryUserKeyedMsg("S2IZ0072", nil)
382  MEMQ(STRING2ID_N(x, 1), '(YES Y)) =>
383    QUIT()
384  nil
385
386--% )compile
387
388compile args ==
389    $newConlist: local := nil    --reset by compDefineLisplib and astran
390    null args and null $options and null($edit_file) =>
391        helpSpad2Cmd '(compile)
392    if null args then args := [$edit_file]
393
394    -- first see if the user has explicitly specified the compiler
395    -- to use.
396
397    optlist := '(new old constructor)
398    haveNew := nil
399    haveOld := nil
400    for opt in $options while not (haveNew and haveOld) repeat
401        [optname,:optargs] := opt
402        fullopt := selectOptionLC(optname,optlist,nil)
403        fullopt = 'new => haveNew := true
404        fullopt = 'constructor => haveOld := true
405        fullopt = 'old => haveOld := true
406
407    haveNew and haveOld => throwKeyedMsg("S2IZ0081", nil)
408
409    af  := pathname args
410    aft := pathnameType af
411
412    haveNew or (aft = '"as")   =>
413        not (af1 := find_file(af, '(as))) =>
414            throwKeyedMsg("S2IL0003",[NAMESTRING af])
415        compileAsharpCmd [af1]
416    haveOld or (aft = '"spad") =>
417        not (af1 := find_file(af, '(spad))) =>
418            throwKeyedMsg("S2IL0003",[NAMESTRING af])
419        compileSpad2Cmd  [af1]
420    aft = '"lsp"   =>
421        not (af1 := find_file(af, '(lsp))) =>
422            throwKeyedMsg("S2IL0003",[NAMESTRING af])
423        compileAsharpLispCmd [af1]
424    aft = '"NRLIB"  =>
425        not (af1 := find_file(af, '(NRLIB))) =>
426            throwKeyedMsg("S2IL0003",[NAMESTRING af])
427        compileSpadLispCmd [af1]
428    aft = '"ao"   =>
429        not (af1 := find_file(af, '(ao))) =>
430            throwKeyedMsg("S2IL0003",[NAMESTRING af])
431        compileAsharpCmd [af1]
432    aft = '"al"   =>    -- archive library of .ao files
433        not (af1 := find_file(af, '(al))) =>
434            throwKeyedMsg("S2IL0003",[NAMESTRING af])
435        compileAsharpArchiveCmd [af1]
436
437    -- see if we something with the appropriate file extension
438    -- lying around
439
440    af1 := find_file(af, '(as spad ao asy))
441
442    af1 and pathnameType(af1) = '"as"   => compileAsharpCmd [af1]
443    af1 and pathnameType(af1) = '"ao"  => compileAsharpCmd [af1]
444    af1 and pathnameType(af1) = '"spad" => compileSpad2Cmd  [af1]
445    af1 and pathnameType(af1) = '"asy"  => compileAsharpArchiveCmd [af1]
446
447    throwKeyedMsg("S2IZ0039", nil)
448
449compileAsharpCmd args ==
450    compileAsharpCmd1 args
451    terminateSystemCommand()
452    spadPrompt()
453
454compileAsharpCmd1 args ==
455    -- Assume we entered from the "compile" function, so args ~= nil
456    -- and is a file with file extension .as or .ao
457
458    path := pathname args
459    pathType := pathnameType path
460    (pathType ~= '"as") and (pathType ~= '"ao") => throwKeyedMsg("S2IZ0083", nil)
461    not PROBE_-FILE path => throwKeyedMsg("S2IL0003",[namestring args])
462
463    $edit_file := path
464
465    optList :=  '( _
466      new _
467      old _
468      onlyargs _
469      moreargs _
470      quiet _
471      nolispcompile _
472      noquiet _
473      library _
474      nolibrary _
475        )
476
477    beQuiet := false         -- be verbose here
478    doLibrary  := true       -- so a )library after compilation
479    doCompileLisp := true    -- do compile generated lisp code
480
481    moreArgs := NIL
482    onlyArgs := NIL
483
484    for opt in $options repeat
485        [optname,:optargs] := opt
486        fullopt := selectOptionLC(optname,optList,nil)
487
488        fullopt = 'new       => nil
489        fullopt = 'old  => error "Internal error: compileAsharpCmd got )old"
490        fullopt = 'quiet     => beQuiet := true
491        fullopt = 'noquiet   => beQuiet := false
492
493        fullopt = 'nolispcompile   => doCompileLisp := false
494
495        fullopt = 'moreargs  => moreArgs := optargs
496        fullopt = 'onlyargs  => onlyArgs := optargs
497
498        fullopt = 'library   => doLibrary  := true
499        fullopt = 'nolibrary => doLibrary  := false
500
501        throwKeyedMsg("S2IZ0036",[STRCONC('")",object2String optname)])
502
503    tempArgs :=
504        pathType = '"ao" =>
505            -- want to strip out -Fao
506            (p := STRPOS('"-Fao", $asharpCmdlineFlags, 0, NIL)) =>
507                p = 0 => SUBSTRING($asharpCmdlineFlags, 5, NIL)
508                STRCONC(SUBSTRING($asharpCmdlineFlags, 0, p), '" ",
509                    SUBSTRING($asharpCmdlineFlags, p+5, NIL))
510            $asharpCmdlineFlags
511        $asharpCmdlineFlags
512
513    asharpArgs :=
514        onlyArgs =>
515            s := ""
516            for a in onlyArgs repeat
517                s := STRCONC(s, '" ", object2String a)
518            s
519        moreArgs =>
520            s := tempArgs
521            for a in moreArgs repeat
522                s := STRCONC(s, '" ", object2String a)
523            s
524        tempArgs
525
526    if not beQuiet then sayKeyedMsg("S2IZ0038A",[namestring args, asharpArgs])
527
528    command :=
529       STRCONC(getEnv('"ALDOR_COMPILER"),_
530                     '" ", asharpArgs, '" ", namestring args)
531    rc := OBEY command
532
533    if (rc = 0) and doCompileLisp then
534        lsp := fnameMake('".", pathnameName args, '"lsp")
535        if fnameReadable?(lsp) then
536            if not beQuiet then sayKeyedMsg("S2IZ0089", [namestring lsp])
537            compileFileQuietly(lsp)
538        else
539            sayKeyedMsg("S2IL0003", [namestring lsp])
540
541    if rc = 0 and doLibrary then
542        -- do we need to worry about where the compilation output went?
543        if not beQuiet then sayKeyedMsg("S2IZ0090", [ pathnameName path ])
544        withAsharpCmd [ pathnameName path ]
545    else if not beQuiet then
546        sayKeyedMsg("S2IZ0084", nil)
547
548    extendLocalLibdb $newConlist
549
550compileAsharpArchiveCmd args ==
551    -- Assume we entered from the "compile" function, so args ~= nil
552    -- and is a file with file extension .al. We also assume that
553    -- the name is fully qualified.
554
555    path := pathname args
556    (FILE_-KIND namestring args) ~= 1 =>
557          throwKeyedMsg("S2IL0003",[namestring args])
558
559    -- here is the plan:
560    --   1. extract the file name and try to make a directory based
561    --      on that name.
562    --   2. cd to that directory and ar x the .al file
563    --   3. for each .ao file that shows up, compile it
564    --   4. delete the generated .ao files
565
566    -- First try to make the directory in the current directory
567
568    dir  := fnameMake('".", pathnameName path, '"axldir")
569    isDir := FILE_-KIND namestring dir
570    isDir = 0 =>
571        throwKeyedMsg("S2IL0027",[namestring dir, namestring args])
572
573    if isDir ~= 1 then
574        cmd  := STRCONC('"mkdir ", namestring dir)
575        rc   := OBEY cmd
576        rc ~= 0 => throwKeyedMsg("S2IL0027",[namestring dir, namestring args])
577
578    curDir := GET_-CURRENT_-DIRECTORY()
579
580    -- cd to that directory and try to unarchive the .al file
581
582    cd [ namestring dir ]
583
584    cmd := STRCONC( '"ar x ", namestring path )
585    rc := OBEY cmd
586    rc ~= 0 =>
587        cd [ namestring curDir ]
588        throwKeyedMsg("S2IL0028",[namestring dir, namestring args])
589
590    -- Look for .ao files
591
592    asos := DIRECTORY '"*.ao"
593    null asos =>
594        cd [ namestring curDir ]
595        throwKeyedMsg("S2IL0029",[namestring dir, namestring args])
596
597    -- Compile the .ao files
598
599    for aso in asos repeat
600        compileAsharpCmd1 [ namestring aso ]
601
602    -- Reset the current directory
603
604    cd [ namestring curDir ]
605
606    terminateSystemCommand()
607    spadPrompt()
608
609compileAsharpLispCmd args ==
610    -- Assume we entered from the "compile" function, so args ~= nil
611    -- and is a file with file extension .lsp
612
613    path := pathname args
614    not PROBE_-FILE path => throwKeyedMsg("S2IL0003",[namestring args])
615
616    optList :=  '( _
617      quiet _
618      noquiet _
619      library _
620      nolibrary _
621        )
622
623    beQuiet := false         -- be verbose here
624    doLibrary  := true       -- so a )library after compilation
625
626    for opt in $options repeat
627        [optname,:optargs] := opt
628        fullopt := selectOptionLC(optname,optList,nil)
629
630        fullopt = 'quiet     => beQuiet := true
631        fullopt = 'noquiet   => beQuiet := false
632
633        fullopt = 'library   => doLibrary  := true
634        fullopt = 'nolibrary => doLibrary  := false
635
636        throwKeyedMsg("S2IZ0036",[STRCONC('")",object2String optname)])
637
638    lsp := fnameMake(pathnameDirectory path, pathnameName path, pathnameType path)
639    if fnameReadable?(lsp) then
640        if not beQuiet then sayKeyedMsg("S2IZ0089", [namestring lsp])
641        compileFileQuietly(lsp)
642    else
643        sayKeyedMsg("S2IL0003", [namestring lsp])
644
645    if doLibrary then
646        -- do we need to worry about where the compilation output went?
647        if not beQuiet then sayKeyedMsg("S2IZ0090", [ pathnameName path ])
648        withAsharpCmd [ pathnameName path ]
649    else if not beQuiet then
650        sayKeyedMsg("S2IZ0084", nil)
651    terminateSystemCommand()
652    spadPrompt()
653
654compileSpadLispCmd args ==
655    -- Assume we entered from the "compile" function, so args ~= nil
656    -- and is a file with file extension .NRLIB
657
658    libname := first args
659    basename := PATHNAME_-NAME(libname)
660    path := pathname fnameMake(libname, basename, '"lsp")
661    not PROBE_-FILE path => throwKeyedMsg("S2IL0003",[namestring args])
662
663    optList :=  '( _
664      quiet _
665      noquiet _
666      library _
667      nolibrary _
668        )
669
670    beQuiet := false         -- be verbose here
671    doLibrary  := true       -- so a )library after compilation
672
673    for opt in $options repeat
674        [optname,:optargs] := opt
675        fullopt := selectOptionLC(optname,optList,nil)
676
677        fullopt = 'quiet     => beQuiet := true
678        fullopt = 'noquiet   => beQuiet := false
679
680        fullopt = 'library   => doLibrary  := true
681        fullopt = 'nolibrary => doLibrary  := false
682
683        throwKeyedMsg("S2IZ0036",[STRCONC('")",object2String optname)])
684
685    lsp := fnameMake(pathnameDirectory path, pathnameName path, pathnameType path)
686    if fnameReadable?(lsp) then
687        if not beQuiet then sayKeyedMsg("S2IZ0089", [namestring lsp])
688        compile_lib_file lsp
689    else
690        sayKeyedMsg("S2IL0003", [namestring lsp])
691
692    if doLibrary then
693        -- do we need to worry about where the compilation output went?
694        if not beQuiet then sayKeyedMsg("S2IZ0090", [ pathnameName path ])
695        LOCALDATABASE([pathnameName(libname)], [])
696    else if not beQuiet then
697        sayKeyedMsg("S2IZ0084", nil)
698    terminateSystemCommand()
699    spadPrompt()
700
701withAsharpCmd args ==
702    $options: local := nil
703    LOCALDATABASE(args, $options)
704
705--% )copyright -- display copyright notice
706
707summary l ==
708 OBEY STRCONC ('"cat ",getEnv('"FRICAS"),'"/lib/summary")
709copyright () ==
710 OBEY STRCONC ('"cat ",getEnv('"FRICAS"),'"/lib/copyright")
711
712--% )credits -- display credit list
713
714credits() ==
715 for i in CREDITS repeat
716  PRINC(i)
717  TERPRI()
718
719--% )display
720
721display l ==
722  ioHook("startSysCmd", "display")
723  UNWIND_-PROTECT(displaySpad2Cmd l, ioHook("endSysCmd", "display"))
724
725displaySpad2Cmd l ==
726  $e: local := $EmptyEnvironment
727  l is [opt,:vl] and opt ~= "?" =>
728    option := selectOptionLC(opt,$displayOptions,'optionError) =>
729
730      -- the option may be given in the plural but the property in
731      -- the alist is sometimes singular
732
733      option :=
734        option = 'all   =>
735            l := ['properties]
736            'properties
737        (option = 'modes) or (option = 'types) =>
738            l := ['type, :vl]
739            'type
740        option = 'values =>
741            l := ['value, :vl]
742            'value
743        option
744
745      option = 'abbreviations =>
746        null vl => listConstructorAbbreviations()
747        for v in vl repeat
748          constructor := abbreviation?(opOf v) => abbQuery(constructor)
749          abbQuery(opOf v)
750
751      option = 'operations =>     displayOperations vl
752      option = 'macros =>         displayMacros vl
753      option = 'names =>          displayWorkspaceNames()
754      displayProperties(option,l)
755  optList:= [:['%l,'"        ",x] for x in $displayOptions]
756  msg := [:bright '"  )display",'"keyword arguments are",
757    :bright optList,'%l,'"   or abbreviations thereof."]
758  sayMessage msg
759
760displayMacros names ==
761  imacs := getInterpMacroNames()
762  pmacs := getParserMacroNames()
763  macros :=
764     null names => APPEND (imacs, pmacs)
765     names
766  macros := REMDUP macros
767
768  null macros => sayBrightly '"   There are no FriCAS macros."
769
770  -- first do user defined ones
771
772  first := true
773  for macro in macros repeat
774    macro in pmacs =>
775        if first then
776            sayBrightly ['%l,'"User-defined macros:"]
777            first := NIL
778        displayParserMacro macro
779    macro in imacs => 'iterate
780    sayBrightly (["   ",'%b, macro, '%d, " is not a known FriCAS macro."])
781
782  -- now system ones
783
784  first := true
785  for macro in macros repeat
786    macro in imacs =>
787        macro in pmacs => 'iterate
788        if first then
789            sayBrightly ['%l,'"System-defined macros:"]
790            first := NIL
791        displayMacro macro
792    macro in pmacs => 'iterate
793  NIL
794
795getParserMacroNames() ==
796  REMDUP [first mac for mac in getParserMacros()]
797
798clearParserMacro(macro) ==
799  -- first see if it is one
800  not IFCDR assoc(macro, ($pfMacros)) => NIL
801  $pfMacros := REMALIST($pfMacros, macro)
802
803displayMacro name ==
804  m := isInterpMacro name
805  null m =>
806    sayBrightly ['"  ",:bright name,'"is not an interpreter macro."]
807  op := STRCONC('"macro ", object2String name)
808  [args,:body] := m
809  args :=
810    null args => nil
811    null rest args => first args
812    ['Tuple,:args]
813  mathprint outputMapTran(op, ['SPADMAP, [args, :body]])
814
815displayWorkspaceNames() ==
816  imacs := getInterpMacroNames()
817  pmacs := getParserMacroNames()
818  sayMessage '"Names of User-Defined Objects in the Workspace:"
819  names := MSORT append(getWorkspaceNames(),pmacs)
820  if null names
821    then sayBrightly "   * None *"
822    else sayAsManyPerLineAsPossible [object2String x for x in names]
823  imacs := SETDIFFERENCE(imacs,pmacs)
824  if imacs then
825    sayMessage '"Names of System-Defined Objects in the Workspace:"
826    sayAsManyPerLineAsPossible [object2String x for x in imacs]
827
828
829getWorkspaceNames() ==
830  NMSORT [n for [n,:.] in CAAR $InteractiveFrame |
831    (n ~= "--macros--" and n~= "--flags--")]
832
833displayOperations l ==
834  null l =>
835    x := UPCASE queryUserKeyedMsg("S2IZ0058",NIL)
836    if MEMQ(STRING2ID_N(x, 1), '(Y YES))
837      then for op in allOperations() repeat reportOpSymbol op
838      else sayKeyedMsg("S2IZ0059",NIL)
839    nil
840  for op in l repeat reportOpSymbol op
841
842interpFunctionDepAlists() ==
843  $e : local := $InteractiveFrame
844  deps := getFlag "$dependencies"
845  $dependentAlist := [[NIL,:NIL]]
846  $dependeeAlist := [[NIL,:NIL]]
847  for [dependee,dependent] in deps repeat
848    $dependentAlist := PUTALIST($dependentAlist,dependee,
849      CONS(dependent,GETALIST($dependentAlist,dependee)))
850    $dependeeAlist  := PUTALIST($dependeeAlist,dependent,
851      CONS(dependee,GETALIST($dependeeAlist,dependent)))
852
853fixObjectForPrinting(v) ==
854    v' := object2Identifier v
855    EQ(v',"%") => '"\%"
856    v' in $msgdbPrims => STRCONC('"\",PNAME v')
857    v
858
859displayProperties(option,l) ==
860  $dependentAlist : local := nil
861  $dependeeAlist  : local := nil
862  [opt,:vl]:= (l or ['properties])
863  imacs := getInterpMacroNames()
864  pmacs := getParserMacroNames()
865  macros := REMDUP append(imacs, pmacs)
866  if vl is ['all] or null vl then
867    vl := MSORT append(getWorkspaceNames(),macros)
868  if $frameMessages then sayKeyedMsg("S2IZ0065",[$interpreterFrameName])
869  null vl =>
870    null $frameMessages => sayKeyedMsg("S2IZ0066",NIL)
871    sayKeyedMsg("S2IZ0067",[$interpreterFrameName])
872  interpFunctionDepAlists()
873  for v in vl repeat
874    isInternalMapName(v) => 'iterate
875    pl := getIProplist(v)
876    option = 'flags =>     getAndSay(v,"flags")
877    option = 'value =>     displayValue(v,getI(v,'value),nil)
878    option = 'condition => displayCondition(v,getI(v,"condition"),nil)
879    option = 'mode =>      displayMode(v,getI(v,'mode),nil)
880    option = 'type =>      displayType(v,getI(v,'value),nil)
881    option = 'properties =>
882      v = "--flags--" => nil
883      pl is [['cacheInfo,:.],:.] => nil
884      v1 := fixObjectForPrinting(v)
885      sayMSG ['"Properties of",:bright prefix2String v1,'":"]
886      null pl =>
887        v in pmacs =>
888            sayMSG '"   This is a user-defined macro."
889            displayParserMacro v
890        isInterpMacro v =>
891            sayMSG '"   This is a system-defined macro."
892            displayMacro v
893        sayMSG '"   none"
894      propsSeen:= nil
895      for [prop,:val] in pl | not MEMQ(prop,propsSeen) and val repeat
896        prop in '(alias generatedCode mapBody localVars) =>
897          nil
898        prop = 'condition =>
899          displayCondition(prop,val,true)
900        prop = 'recursive =>
901          sayMSG '"   This is recursive."
902        prop = 'isInterpreterFunction =>
903          sayMSG '"   This is an interpreter function."
904          sayFunctionDeps v
905        prop = 'isInterpreterRule =>
906          sayMSG '"   This is an interpreter rule."
907          sayFunctionDeps v
908        prop = 'localModemap =>
909          displayModemap(v,val,true)
910        prop = 'mode =>
911          displayMode(prop,val,true)
912        prop = 'value =>
913          val => displayValue(v,val,true)
914        sayMSG ['"   ",prop,'":  ",val]
915        propsSeen:= [prop,:propsSeen]
916    sayKeyedMsg("S2IZ0068",[option])
917  terminateSystemCommand()
918
919sayFunctionDeps x ==
920  if dependents := GETALIST($dependentAlist,x) then
921    null rest dependents =>
922      sayMSG ['"   The following function or rule ",
923        '"depends on this:",:bright first dependents]
924    sayMSG
925      '"   The following functions or rules depend on this:"
926    msg := ["%b",'"     "]
927    for y in dependents repeat msg := ['" ",y,:msg]
928    sayMSG [:nreverse msg,"%d"]
929  if dependees := GETALIST($dependeeAlist,x) then
930    null rest dependees =>
931      sayMSG ['"   This depends on the following function ",
932        '"or rule:",:bright first dependees]
933    sayMSG
934      '"   This depends on the following functions or rules:"
935    msg := ["%b",'"     "]
936    for y in dependees repeat msg := ['" ",y,:msg]
937    sayMSG [:nreverse msg,"%d"]
938
939displayModemap(v,val,giveVariableIfNil) ==
940  for mm in val repeat g(v,mm,giveVariableIfNil) where
941    g(v,mm,giveVariableIfNil) ==
942      [[local,:signature],fn,:.]:= mm
943      local='interpOnly => nil
944      varPart:= (giveVariableIfNil => nil; ['" of",:bright v])
945      prefix:= ["   Compiled function type",:varPart,": "]
946      sayBrightly concat(prefix,formatSignature signature)
947
948displayMode(v,mode,giveVariableIfNil) ==
949  null mode => nil
950  varPart:= (giveVariableIfNil => nil; [" of",:bright fixObjectForPrinting v])
951  sayBrightly concat("   Declared type or mode",
952    varPart,":   ",prefix2String mode)
953
954displayCondition(v,condition,giveVariableIfNil) ==
955  varPart:= (giveVariableIfNil => nil; [" of",:bright v])
956  condPart:= condition or 'true
957  sayBrightly concat("   condition",varPart,":  ",pred2English condPart)
958
959getAndSay(v,prop) ==
960  val:= getI(v,prop) => sayMSG ["    ",val,'%l]
961  sayMSG ["    none",'%l]
962
963displayType(op, u, omitVariableNameIfTrue) ==
964  null u =>
965    sayMSG ['"   Type of value of ",
966        fixObjectForPrinting PNAME op, '":  (none)"]
967  type := prefix2String objMode(u)
968  if ATOM type then type := [type]
969  sayMSG concat ['"   Type of value of ", fixObjectForPrinting PNAME op,
970                 '": ", :type]
971  NIL
972
973displayValue(op, u, omitVariableNameIfTrue) ==
974  null u => sayMSG ["   Value of ", fixObjectForPrinting PNAME op,
975                    '":  (none)"]
976  expr := objValUnwrap(u)
977  expr is [op1, :.] and (op1 = 'SPADMAP) =>
978      displayRule(op, expr)
979  objMode(u) = $EmptyMode => BREAK()
980  label:=
981    omitVariableNameIfTrue =>
982        rhs := '"):  "
983        '"Value (has type "
984    rhs := '":  "
985    STRCONC('"Value of ", PNAME op, '": ")
986  labmode := prefix2String objMode(u)
987  if ATOM labmode then labmode := [labmode]
988  GETDATABASE(expr,'CONSTRUCTORKIND) = 'domain =>
989    sayMSG concat('"   ",label,labmode,rhs,form2String expr)
990  mathprint ['CONCAT,label,:labmode,rhs,
991    outputFormat(expr,objMode(u))]
992  NIL
993
994--% )edit
995
996edit l == editSpad2Cmd l
997
998editSpad2Cmd l ==
999  l:=
1000    null l => $edit_file
1001    first l
1002  l := pathname l
1003  oldDir := pathnameDirectory l
1004  fileTypes :=
1005    pathnameType l => [pathnameType l]
1006    $UserLevel = 'interpreter => '("input" "INPUT" "spad" "SPAD")
1007    $UserLevel = 'compiler    => '("input" "INPUT" "spad" "SPAD")
1008    '("input" "INPUT" "spad" "SPAD" "boot" "BOOT" "lisp" "LISP")
1009  ll :=
1010       oldDir = '"" => pathname find_file(pathnameName l, fileTypes)
1011       l
1012  l := pathname ll
1013  $edit_file := l
1014  rc := editFile l
1015  rc
1016
1017--% )help
1018
1019help l == helpSpad2Cmd l
1020
1021helpSpad2Cmd args ==
1022  -- try to use new stuff first
1023  if newHelpSpad2Cmd(args) then return nil
1024
1025  sayBrightly "Available help topics for system commands are:"
1026  sayBrightly ""
1027  sayBrightly " boot   cd     clear    close     compile   display"
1028  sayBrightly " edit   fin    frame    help      history   library"
1029  sayBrightly " lisp   load   ltrace   pquit     quit      read"
1030  sayBrightly " set    show   spool    synonym   system    trace"
1031  sayBrightly " undo   what"
1032  sayBrightly ""
1033  sayBrightly "Issue _")help help_" for more information about the help command."
1034
1035  nil
1036
1037newHelpSpad2Cmd args ==
1038  if null args then args := ["?"]
1039  # args > 1 =>
1040    sayKeyedMsg("S2IZ0026",NIL)
1041    true
1042  sarg := PNAME first args
1043  if sarg = '"?" then args := ['nullargs]
1044  else if sarg = '"%" then args := ['history]
1045       else if sarg = '"%%" then args := ['history]
1046  arg := selectOptionLC(first args,$SYSCOMMANDS,nil)
1047  if null arg then arg := first args
1048
1049  -- see if new help file exists
1050
1051  narg := PNAME arg
1052  null(helpFile := make_input_filename([narg, 'HELPSPAD])) => nil
1053
1054  $useFullScreenHelp =>
1055    OBEY STRCONC('"$FRICAS/lib/SPADEDIT ",namestring helpFile)
1056    true
1057
1058  filestream := MAKE_INSTREAM(helpFile)
1059  repeat
1060    line := read_line(filestream)
1061    NULL line =>
1062      SHUT filestream
1063      return true
1064    SAY line
1065  true
1066
1067--%
1068--% )frame
1069--%
1070
1071$frameRecord  := nil  --Initial setting for frame record
1072$previousBindings := nil
1073
1074frame l == frameSpad2Cmd l
1075
1076frameName(frame) == first frame
1077
1078frameNames() == [frameName f for f in $interpreterFrameRing]
1079
1080frameEnvironment fname ==
1081  -- extracts the environment portion of a frame
1082  -- if fname is not a valid frame name then the empty environment
1083  -- is returned
1084  fname = frameName first $interpreterFrameRing => $InteractiveFrame
1085  ifr := rest $interpreterFrameRing
1086  e := LIST LIST NIL
1087  while ifr repeat
1088    [f,:ifr] := ifr
1089    if fname = frameName f   then
1090      e := CADR f
1091      ifr := NIL
1092  e
1093
1094frameSpad2Cmd args ==
1095  frameArgs := '(drop import last names new next)
1096  $options => throwKeyedMsg("S2IZ0016",['")frame"])
1097  null(args) => helpSpad2Cmd ['frame]
1098  arg  := selectOptionLC(first args,frameArgs,'optionError)
1099  args := rest args
1100  if args is [a] then args := a
1101  if ATOM args then args := object2Identifier args
1102  arg = 'drop  =>
1103    args and PAIRP(args) => throwKeyedMsg("S2IZ0017",[args])
1104    closeInterpreterFrame(args)
1105  arg = 'import =>  importFromFrame args
1106  arg = 'last  =>   previousInterpreterFrame()
1107  arg = 'names =>   displayFrameNames()
1108  arg = 'new   =>
1109    args and PAIRP(args) => throwKeyedMsg("S2IZ0017",[args])
1110    addNewInterpreterFrame(args)
1111  arg = 'next  =>   nextInterpreterFrame()
1112
1113  NIL
1114
1115addNewInterpreterFrame(name) ==
1116  null name => throwKeyedMsg("S2IZ0018",NIL)
1117  updateCurrentInterpreterFrame()
1118  -- see if we already have one by that name
1119  for f in $interpreterFrameRing repeat
1120    name = frameName(f) => throwKeyedMsg("S2IZ0019",[name])
1121  initHistList()
1122  $interpreterFrameRing := CONS(emptyInterpreterFrame(name),
1123    $interpreterFrameRing)
1124  updateFromCurrentInterpreterFrame()
1125  erase_lib([histFileName()])
1126
1127emptyInterpreterFrame(name) ==
1128  LIST(name,                            -- frame name
1129       LIST LIST NIL,                   -- environment
1130       1,                               -- $IOindex
1131       $HiFiAccess,                     -- $HiFiAccess
1132       $HistList,                       -- $HistList
1133       $HistListLen,                    -- $HistListLen
1134       $HistListAct,                    -- $HistListAct
1135       $HistRecord,                     -- $HistRecord
1136       NIL,                             -- $internalHistoryTable
1137       COPY_-SEQ $localExposureDataDefault        -- $localExposureData
1138      )
1139
1140closeInterpreterFrame(name) ==
1141  -- if name = NIL then it means the current frame
1142  null rest $interpreterFrameRing =>
1143    name and (name ~= $interpreterFrameName) =>
1144      throwKeyedMsg("S2IZ0020",[$interpreterFrameName])
1145    throwKeyedMsg("S2IZ0021",NIL)
1146  if null name then $interpreterFrameRing := rest $interpreterFrameRing
1147  else   -- find the frame
1148    found := nil
1149    ifr := NIL
1150    for f in $interpreterFrameRing repeat
1151      found or (name ~= frameName(f)) => ifr := CONS(f,ifr)
1152      found := true
1153    not found => throwKeyedMsg("S2IZ0022",[name])
1154    erase_lib([makeHistFileName(name)])
1155    $interpreterFrameRing := nreverse ifr
1156  updateFromCurrentInterpreterFrame()
1157
1158previousInterpreterFrame() ==
1159  updateCurrentInterpreterFrame()
1160  null rest $interpreterFrameRing => NIL  -- nothing to do
1161  [:b,l] := $interpreterFrameRing
1162  $interpreterFrameRing := NCONC2([l],b)
1163  updateFromCurrentInterpreterFrame()
1164
1165nextInterpreterFrame() ==
1166  updateCurrentInterpreterFrame()
1167  null rest $interpreterFrameRing => NIL  -- nothing to do
1168  $interpreterFrameRing :=
1169    NCONC2(rest $interpreterFrameRing,[first $interpreterFrameRing])
1170  updateFromCurrentInterpreterFrame()
1171
1172
1173createCurrentInterpreterFrame() ==
1174  LIST($interpreterFrameName,           -- frame name
1175       $InteractiveFrame,               -- environment
1176       $IOindex,                        -- $IOindex
1177       $HiFiAccess,                     -- $HiFiAccess
1178       $HistList,                       -- $HistList
1179       $HistListLen,                    -- $HistListLen
1180       $HistListAct,                    -- $HistListAct
1181       $HistRecord,                     -- $HistRecord
1182       $internalHistoryTable,           -- $internalHistoryTable
1183       $localExposureData               -- $localExposureData
1184      )
1185
1186
1187updateFromCurrentInterpreterFrame() ==
1188  [$interpreterFrameName,          _
1189   $InteractiveFrame,              _
1190   $IOindex,                       _
1191   $HiFiAccess,                    _
1192   $HistList,                      _
1193   $HistListLen,                   _
1194   $HistListAct,                   _
1195   $HistRecord,                    _
1196   $internalHistoryTable,          _
1197   $localExposureData              _
1198   ] := first $interpreterFrameRing
1199  if $frameMessages then
1200    sayMessage ['"   Current interpreter frame is called",:bright
1201      $interpreterFrameName]
1202  NIL
1203
1204
1205updateCurrentInterpreterFrame() ==
1206  RPLACA($interpreterFrameRing,createCurrentInterpreterFrame())
1207  updateFromCurrentInterpreterFrame()
1208  NIL
1209
1210initializeInterpreterFrameRing() ==
1211  $interpreterFrameName := 'initial
1212  $interpreterFrameRing := [emptyInterpreterFrame($interpreterFrameName)]
1213  updateFromCurrentInterpreterFrame()
1214  NIL
1215
1216
1217changeToNamedInterpreterFrame(name) ==
1218  updateCurrentInterpreterFrame()
1219  frame := findFrameInRing(name)
1220  null frame => NIL
1221  $interpreterFrameRing := [frame,:NREMOVE($interpreterFrameRing, frame)]
1222  updateFromCurrentInterpreterFrame()
1223
1224makeInitialModemapFrame() == COPY $InitialModemapFrame
1225
1226findFrameInRing(name) ==
1227  val := NIL
1228  for frame in $interpreterFrameRing repeat
1229    first frame = name =>
1230      val := frame
1231      return frame
1232  val
1233
1234displayFrameNames() ==
1235  fs := "append"/[ ['%l,'"     ",:bright frameName f] for f in
1236    $interpreterFrameRing]
1237  sayKeyedMsg("S2IZ0024",[fs])
1238
1239importFromFrame args ==
1240  -- args should have the form [frameName,:varNames]
1241  if args and atom args then args := [args]
1242  null args => throwKeyedMsg("S2IZ0073",NIL)
1243  [fname,:args] := args
1244  not member(fname,frameNames()) =>
1245    throwKeyedMsg("S2IZ0074",[fname])
1246  fname = frameName first $interpreterFrameRing =>
1247    throwKeyedMsg("S2IZ0075",NIL)
1248  fenv := frameEnvironment fname
1249  null args =>
1250    x := UPCASE queryUserKeyedMsg("S2IZ0076",[fname])
1251    MEMQ(STRING2ID_N(x, 1), '(Y YES)) =>
1252      vars := NIL
1253      for [v,:props] in CAAR fenv repeat
1254        v = "--macros" =>
1255          for [m,:.] in props repeat vars := cons(m,vars)
1256        vars := cons(v,vars)
1257      importFromFrame [fname,:vars]
1258    sayKeyedMsg("S2IZ0077",[fname])
1259  for v in args repeat
1260    plist := GETALIST(CAAR fenv,v)
1261    plist =>
1262      -- remove anything with the same name in the current frame
1263      clearCmdParts ['propert,v]
1264      for [prop,:val] in plist repeat
1265        putHist(v,prop,val,$InteractiveFrame)
1266    (m := get("--macros--",v,fenv)) =>
1267      putHist("--macros--",v,m,$InteractiveFrame)
1268    sayKeyedMsg("S2IZ0079",[v,fname])
1269  sayKeyedMsg("S2IZ0078",[fname])
1270
1271
1272
1273--% )history
1274
1275++ vm/370 filename type component
1276DEFPARAMETER($historyFileType, 'axh)
1277
1278++ vm/370 filename name component
1279DEFPARAMETER($oldHistoryFileName, 'last)
1280DEFPARAMETER($internalHistoryTable, NIL)
1281
1282++ t means keep history in core
1283DEFPARAMETER($useInternalHistoryTable, true)
1284
1285history l ==
1286  l or null $options => sayKeyedMsg("S2IH0006",NIL)
1287  historySpad2Cmd()
1288
1289
1290makeHistFileName(fname) ==
1291  makePathname(fname,$historyFileType)
1292
1293oldHistFileName() ==
1294  makeHistFileName($oldHistoryFileName)
1295
1296DEFPARAMETER($curHistFileName, nil)
1297
1298histFileName() ==
1299  $curHistFileName => makeHistFileName($curHistFileName)
1300  makeHistFileName($interpreterFrameName)
1301
1302
1303histInputFileName(fn) ==
1304  null fn =>
1305    makePathname($interpreterFrameName,'INPUT)
1306  makePathname(fn,'INPUT)
1307
1308
1309initHist() ==
1310  $useInternalHistoryTable => initHistList()
1311  oldFile := oldHistFileName()
1312  newFile := histFileName()
1313  -- see if history directory is writable
1314  histFileErase oldFile
1315  if make_input_filename(newFile) then replace_lib(newFile, oldFile)
1316  $HiFiAccess:= 'T
1317  initHistList()
1318
1319initHistList() ==
1320  -- creates $HistList as a circular list of length $HistListLen
1321  -- and $HistRecord
1322  $HistListLen:= 20
1323  $HistList:= LIST NIL
1324  li:= $HistList
1325  for i in 1..$HistListLen repeat li:= CONS(NIL,li)
1326  RPLACD($HistList,li)
1327  $HistListAct:= 0
1328  $HistRecord:= NIL
1329
1330historySpad2Cmd() ==
1331  -- history is a system command which can call resetInCoreHist
1332  -- and changeHistListLen, and restore last session
1333  histOptions:=
1334    '(on off yes no change reset restore write save show file memory)
1335  opts:= [ [selectOptionLC(opt,histOptions,'optionError),:optargs]
1336    for [opt,:optargs] in $options]
1337  for [opt,:optargs] in opts repeat
1338    opt in '(on yes) =>
1339      $HiFiAccess => sayKeyedMsg("S2IH0007",NIL)
1340      $IOindex = 1 =>       -- haven't done anything yet
1341        $HiFiAccess:= 'T
1342        initHistList()
1343        sayKeyedMsg("S2IH0008",NIL)
1344      x := UPCASE queryUserKeyedMsg("S2IH0009",NIL)
1345      MEMQ(STRING2ID_N(x, 1), '(Y YES)) =>
1346        histFileErase histFileName()
1347        $HiFiAccess:= 'T
1348        $options := nil
1349        clearSpad2Cmd '(all)
1350        sayKeyedMsg("S2IH0008",NIL)
1351        initHistList()
1352      sayKeyedMsg("S2IH0010",NIL)
1353    opt in '(off no) =>
1354      null $HiFiAccess => sayKeyedMsg("S2IH0011",NIL)
1355      $HiFiAccess:= NIL
1356      disableHist()
1357      sayKeyedMsg("S2IH0012",NIL)
1358    opt = 'file    => setHistoryCore NIL
1359    opt = 'memory  => setHistoryCore true
1360    opt = 'reset   => resetInCoreHist()
1361    opt = 'save    => saveHistory optargs
1362    opt = 'show    => showHistory optargs
1363    opt = 'change  => changeHistListLen first optargs
1364    opt = 'restore => restoreHistory optargs
1365    opt = 'write   => writeInputLines(optargs,1)
1366  'done
1367
1368
1369setHistoryCore inCore ==
1370  inCore = $useInternalHistoryTable =>
1371    sayKeyedMsg((inCore => "S2IH0030"; "S2IH0029"),NIL)
1372  not $HiFiAccess =>
1373    $useInternalHistoryTable := inCore
1374    inCore => sayKeyedMsg("S2IH0032",NIL)
1375    sayKeyedMsg("S2IH0031",NIL)
1376  inCore =>
1377    $internalHistoryTable := NIL
1378    if $IOindex ~= 0 then
1379      -- actually put something in there
1380      l := LENGTH RKEYIDS histFileName()
1381      for i in 1..l repeat
1382        vec:= UNWIND_-PROTECT(readHiFi(i),disableHist())
1383        $internalHistoryTable := CONS([i,:vec],$internalHistoryTable)
1384      histFileErase histFileName()
1385    $useInternalHistoryTable := true
1386    sayKeyedMsg("S2IH0032",NIL)
1387  $HiFiAccess:= 'NIL
1388  histFileErase histFileName()
1389  str := rMkOstream(histFileName())
1390  for [n,:rec] in reverse $internalHistoryTable repeat
1391    SPADRWRITE(object2Identifier n,rec,str)
1392  RSHUT str
1393  $HiFiAccess:= 'T
1394  $internalHistoryTable := NIL
1395  $useInternalHistoryTable := NIL
1396  sayKeyedMsg("S2IH0031",NIL)
1397
1398
1399writeInputLines(fn,initial) ==
1400  -- writes all input lines into file histInputFileName()
1401  not $HiFiAccess => sayKeyedMsg("S2IH0013",NIL) -- history not on
1402  null fn =>
1403    throwKeyedMsg("S2IH0038", nil)          -- missing file name
1404  maxn := 72
1405  breakChars := [" ","+"]
1406  for i in initial..$IOindex - 1 repeat
1407    vecl := first readHiFi i
1408    if STRINGP vecl then vecl := [vecl]
1409    for vec in vecl repeat
1410      n := SIZE vec
1411      while n > maxn repeat
1412        -- search backwards for a blank
1413        done := nil
1414        for j in 1..maxn while not done repeat
1415          k := 1 + maxn - j
1416          MEMQ(vec.k,breakChars) =>
1417            svec := STRCONC(SUBSTRING(vec,0,k+1),UNDERBAR)
1418            lineList := [svec,:lineList]
1419            done := true
1420            vec := SUBSTRING(vec,k+1,NIL)
1421            n := SIZE vec
1422        -- in case we can't find a breaking point
1423        if not done then n := 0
1424      lineList := [vec,:lineList]
1425  file := histInputFileName(fn)
1426  maybe_delete_file(file)
1427  inp := MAKE_OUTSTREAM(file)
1428  for x in removeUndoLines NREVERSE lineList repeat WRITE_-LINE(x,inp)
1429  -- see file "undo" for definition of removeUndoLines
1430  if fn ~= 'redo then sayKeyedMsg("S2IH0014",[namestring file])
1431  SHUT inp
1432  NIL
1433
1434
1435resetInCoreHist() ==
1436  -- removes all pointers from $HistList
1437  $HistListAct:= 0
1438  for i in 1..$HistListLen repeat
1439    $HistList := rest $HistList
1440    RPLACA($HistList,NIL)
1441
1442changeHistListLen(n) ==
1443  -- changes the length of $HistList.  n must be nonnegative
1444  NULL INTEGERP n => sayKeyedMsg("S2IH0015",[n])
1445  dif:= n-$HistListLen
1446  $HistListLen:= n
1447  l := rest $HistList
1448  if dif > 0 then
1449    for i in 1..dif repeat l:= CONS(NIL,l)
1450  if dif < 0 then
1451    for i in 1..-dif repeat l := rest l
1452    if $HistListAct > n then $HistListAct:= n
1453  RPLACD($HistList,l)
1454  'done
1455
1456updateHist() ==
1457  -- updates the history file and calls updateInCoreHist
1458  null $IOindex => nil
1459  startTimingProcess 'history
1460  updateInCoreHist()
1461  if $HiFiAccess then
1462    UNWIND_-PROTECT(writeHiFi(),disableHist())
1463    $HistRecord:= NIL
1464  $IOindex:= $IOindex+1
1465  updateCurrentInterpreterFrame()
1466  $currentLine := nil
1467  stopTimingProcess 'history
1468
1469updateInCoreHist() ==
1470  -- updates $HistList and $IOindex
1471  $HistList := rest($HistList)
1472  RPLACA($HistList,NIL)
1473  if $HistListAct < $HistListLen then $HistListAct:= $HistListAct+1
1474
1475putHist(x,prop,val,e) ==
1476  -- records new value to $HistRecord and old value to $HistList
1477  -- then put is called with e
1478  if not (x='%) then recordOldValue(x,prop,get(x,prop,e))
1479  if $HiFiAccess then recordNewValue(x,prop,val)
1480  putIntSymTab(x,prop,val,e)
1481
1482histFileErase(file) == erase_lib([file])
1483
1484recordNewValue(x,prop,val) ==
1485  startTimingProcess 'history
1486  recordNewValue0(x,prop,val)
1487  stopTimingProcess 'history
1488
1489recordNewValue0(x,prop,val) ==
1490  -- writes (prop . val) into $HistRecord
1491  -- updateHist writes this stuff out into the history file
1492  p1:= ASSQ(x,$HistRecord) =>
1493    p2 := ASSQ(prop, rest p1) =>
1494      RPLACD(p2,val)
1495    RPLACD(p1, CONS(CONS(prop, val), rest p1))
1496  p:= CONS(x,list CONS(prop,val))
1497  $HistRecord:= CONS(p,$HistRecord)
1498
1499recordOldValue(x,prop,val) ==
1500  startTimingProcess 'history
1501  recordOldValue0(x,prop,val)
1502  stopTimingProcess 'history
1503
1504recordOldValue0(x,prop,val) ==
1505  -- writes (prop . val) into $HistList
1506  p1 := ASSQ(x, first $HistList) =>
1507    not ASSQ(prop, rest p1) =>
1508      RPLACD(p1, CONS(CONS(prop, val), rest p1))
1509  p:= CONS(x,list CONS(prop,val))
1510  RPLACA($HistList, CONS(p, first $HistList))
1511
1512undoInCore(n) ==
1513  -- undoes the last n>0 steps using $HistList
1514  -- resets $InteractiveFrame
1515  li:= $HistList
1516  for i in n..$HistListLen repeat li := rest li
1517  undoChanges(li)
1518  n:= $IOindex-n-1
1519  n>0 and
1520    $HiFiAccess =>
1521      vec := rest UNWIND_-PROTECT(readHiFi(n), disableHist())
1522      val := (p := ASSQ('%, vec)) and (p1 := ASSQ('value, rest p)) and
1523        rest p1
1524    sayKeyedMsg("S2IH0019",[n])
1525  $InteractiveFrame:= putHist('%,'value,val,$InteractiveFrame)
1526  updateHist()
1527
1528undoChanges(li) ==
1529  -- undoes all changes of list 'li'
1530  if not (rest li = $HistList) then undoChanges rest li
1531  for p1 in first li repeat
1532    x := first p1
1533    for p2 in rest p1 repeat
1534      putHist(x, first p2, rest p2, $InteractiveFrame)
1535
1536undoFromFile(n) ==
1537  -- makes a clear and redoes all the assignments until step n
1538  for [x,:varl] in CAAR $InteractiveFrame repeat
1539    for p in varl repeat
1540      [prop,:val]:= p
1541      val =>
1542        if not (x='%) then recordOldValue(x,prop,val)
1543        if $HiFiAccess then recordNewValue(x,prop,val)
1544        RPLACD(p,NIL)
1545  for i in 1..n repeat
1546    vec := UNWIND_-PROTECT(rest readHiFi(i), disableHist())
1547    for p1 in vec repeat
1548      x := first p1
1549      for p2 in rest p1 repeat
1550        $InteractiveFrame := putHist(x, first p2, rest p2, $InteractiveFrame)
1551  val := (p := ASSQ('%, vec)) and (p1 := ASSQ('value, rest p)) and rest p1
1552  $InteractiveFrame:= putHist('%,'value,val,$InteractiveFrame)
1553  updateHist()
1554
1555saveHistory(fn) ==
1556  $seen : local := MAKE_HASHTABLE('EQ)
1557  not $HiFiAccess => sayKeyedMsg("S2IH0016",NIL)
1558  not $useInternalHistoryTable and
1559      null(make_input_filename(histFileName())) =>
1560          sayKeyedMsg("S2IH0022", nil)
1561  null fn =>
1562    throwKeyedMsg("S2IH0037", nil)
1563  savefile := makeHistFileName(fn)
1564  inputfile := histInputFileName(fn)
1565  writeInputLines(fn,1)
1566  histFileErase savefile
1567
1568  if $useInternalHistoryTable
1569    then
1570      saveStr := rMkOstream(savefile)
1571      for [n,:rec] in reverse $internalHistoryTable repeat
1572        val := SPADRWRITE0(object2Identifier n,rec,saveStr)
1573        val = 'writifyFailed =>
1574          sayKeyedMsg("S2IH0035", [n, inputfile]) -- unable to save step
1575      RSHUT saveStr
1576  sayKeyedMsg("S2IH0018",[namestring(savefile)])  -- saved hist file named
1577  nil
1578
1579restoreHistory(fn) ==
1580  -- uses fn $historyFileType to recover an old session
1581  -- if fn = NIL, then use $oldHistoryFileName
1582  if null fn then fn' := $oldHistoryFileName
1583  else if fn is [fn'] and IDENTP(fn') then fn' := fn'
1584       else throwKeyedMsg("S2IH0023",[fn'])
1585  restfile := makeHistFileName(fn')
1586  null(make_input_filename(restfile)) =>
1587    sayKeyedMsg("S2IH0024",[namestring(restfile)]) -- no history file
1588
1589  -- if clear is changed to be undoable, this should be a reset-clear
1590  $options: local := nil
1591  clearSpad2Cmd '(all)
1592  oldInternal := $useInternalHistoryTable
1593  restoreHistory2(oldInternal, restfile, fn')
1594  sayKeyedMsg("S2IH0025",[namestring(restfile)])
1595  clear_sorted_caches()
1596  nil
1597
1598restoreHistory2(oldInternal, restfile, fn) ==
1599  $curHistFileName : local := fn
1600  $useInternalHistoryTable : local := nil
1601  if not(oldInternal) then
1602     curfile := histFileName()
1603     histFileErase curfile
1604     copy_file(restfile, curfile)
1605     $curHistFileName := nil
1606     restfile := curfile
1607
1608  l:= LENGTH RKEYIDS restfile
1609  $HiFiAccess:= 'T
1610  if oldInternal then $internalHistoryTable := NIL
1611  for i in 1..l repeat
1612    vec:= UNWIND_-PROTECT(readHiFi(i),disableHist())
1613    if oldInternal then $internalHistoryTable :=
1614      CONS([i,:vec],$internalHistoryTable)
1615    LINE := first vec
1616    for p1 in rest vec repeat
1617      x := first p1
1618      for p2 in rest p1 repeat
1619        $InteractiveFrame := putHist(x, first p2, rest p2, $InteractiveFrame)
1620    updateInCoreHist()
1621  $e := $InteractiveFrame
1622  for [a,:.] in CAAR $InteractiveFrame repeat
1623    get(a,'localModemap,$InteractiveFrame) =>
1624      rempropI(a,'localModemap)
1625      rempropI(a,'localVars)
1626      rempropI(a,'mapBody)
1627  $IOindex:= l+1
1628  $useInternalHistoryTable := oldInternal
1629
1630
1631-- the following used to be the show command when that was used to
1632-- show history.
1633showHistory(arg) ==
1634  -- arg can be of form
1635  --    NIL          show at most last 20 input lines
1636  --    (n)          show at most last n input lines
1637  --    (lit)        where lit is an abbreviation for 'input or 'both
1638  --                 if 'input, same as NIL
1639  --                 if 'both, show last 5 input and outputs
1640  --    (n lit)      show last n input lines + last n output lines
1641  --                 if lit expands to 'both
1642  $evalTimePrint: local:= 0
1643  $printTimeSum: local:= 0
1644  -- ugh!!! these are needed for timedEvaluateStream
1645  -- displays the last n steps, default n=20
1646  not $HiFiAccess => sayKeyedMsg("S2IH0026",['show])
1647  showInputOrBoth := 'input
1648  n := 20
1649  nset := nil
1650  if arg then
1651    arg1 := first arg
1652    if INTEGERP arg1 then
1653      n := arg1
1654      nset := true
1655      IFCDR arg => arg1 := CADR arg
1656      arg1 := NIL
1657    arg1 =>
1658      arg2 := selectOptionLC(arg1,'(input both),nil)
1659      if arg2
1660        then ((showInputOrBoth := arg2) = 'both) and (null nset) => n:= 5
1661        else sayMSG
1662          concat('"  ",bright arg1,'"is an invalid argument.")
1663  if n >= $IOindex then n:= $IOindex-1
1664  mini:= $IOindex-n
1665  maxi:= $IOindex-1
1666  showInputOrBoth = 'both =>
1667    UNWIND_-PROTECT(showInOut(mini,maxi),setIOindex(maxi+1))
1668  showInput(mini,maxi)
1669
1670setIOindex(n) ==
1671  -- set $IOindex to n
1672  $IOindex:= n
1673
1674showInput(mini,maxi) ==
1675  -- displays all input lines from mini to maxi
1676  for ind in mini..maxi repeat
1677    vec:= UNWIND_-PROTECT(readHiFi(ind),disableHist())
1678    if ind<10 then TAB 2 else if ind<100 then TAB 1
1679    l := first vec
1680    STRINGP l =>
1681      sayMSG ['"   [", ind, '"] ", first vec]
1682    sayMSG ['"   [",ind,'"] " ]
1683    for ln in l repeat
1684      sayMSG ['"      ", ln]
1685
1686showInOut(mini,maxi) ==
1687  -- displays all steps from mini to maxi
1688  for ind in mini..maxi repeat
1689    vec:= UNWIND_-PROTECT(readHiFi(ind),disableHist())
1690    sayMSG [first vec]
1691    Alist := ASSQ('%, rest vec) =>
1692      triple := rest ASSQ('value, rest Alist)
1693      $IOindex:= ind
1694      spadPrint(objValUnwrap triple,objMode triple)
1695
1696fetchOutput(n) ==
1697  -- result is the output of step n
1698  (n = -1) and (val := getI("%",'value)) => val
1699  $HiFiAccess =>
1700    n:=
1701      n < 0 => $IOindex+n
1702      n
1703    n >= $IOindex => throwKeyedMsg("S2IH0001",[n])
1704    n < 1        => throwKeyedMsg("S2IH0002",[n])
1705    vec:= UNWIND_-PROTECT(readHiFi(n),disableHist())
1706    Alist := ASSQ('%, rest vec) =>
1707      val := rest ASSQ('value, rest Alist) => val
1708      throwKeyedMsg("S2IH0003",[n])
1709    throwKeyedMsg("S2IH0003",[n])
1710  throwKeyedMsg("S2IH0004",NIL)
1711
1712readHiFi(n) ==
1713  -- reads the file using index n
1714  if $useInternalHistoryTable
1715  then
1716    pair := assoc(n,$internalHistoryTable)
1717    ATOM pair => keyedSystemError("S2IH0034",NIL)
1718    vec := QCDR pair
1719  else
1720    HiFi:= rMkIstream(histFileName())
1721    vec:= SPADRREAD(object2Identifier n,HiFi)
1722    RSHUT HiFi
1723  vec
1724
1725writeHiFi() ==
1726  -- writes the information of the current step out to history file
1727  if $useInternalHistoryTable
1728  then
1729    $internalHistoryTable := CONS([$IOindex,$currentLine,:$HistRecord],
1730      $internalHistoryTable)
1731  else
1732    HiFi:= rMkOstream(histFileName())
1733    SPADRWRITE(object2Identifier $IOindex, CONS($currentLine,$HistRecord),HiFi)
1734    RSHUT HiFi
1735
1736disableHist() ==
1737  -- disables the history mechanism if an error occurred in the protected
1738  -- piece of code
1739  not $HiFiAccess => histFileErase histFileName()
1740  NIL
1741
1742writeHistModesAndValues() ==
1743  for [a,:.] in CAAR $InteractiveFrame repeat
1744    x := get(a,'value,$InteractiveFrame) =>
1745      putHist(a,'value,x,$InteractiveFrame)
1746    x := get(a,'mode,$InteractiveFrame) =>
1747      putHist(a,'mode,x,$InteractiveFrame)
1748  NIL
1749
1750SPADRREAD(vec, stream) ==
1751    dewritify rread(vec, stream)
1752
1753--% Lisplib output transformations
1754--  Some types of objects cannot be saved by LISP/VM in lisplibs.
1755--  These functions transform an object to a writable form and back.
1756--  SMW
1757SPADRWRITE(vec, item, stream) ==
1758  val := SPADRWRITE0(vec, item, stream)
1759  val = 'writifyFailed =>
1760    throwKeyedMsg("S2IH0036", nil) -- cannot save value to file
1761  item
1762
1763SPADRWRITE0(vec, item, stream) ==
1764    val := safeWritify item
1765    val = 'writifyFailed => val
1766    rwrite(vec, val, stream)
1767    item
1768
1769safeWritify ob ==
1770  CATCH('writifyTag,  writify ob)
1771
1772writify ob ==
1773    not ScanOrPairVec(function(unwritable?), ob) => ob
1774    $seen : local := MAKE_HASHTABLE('EQ)
1775    $writifyComplained: local := false
1776
1777    writifyInner ob where
1778        writifyInner ob ==
1779            null ob                => nil
1780            (e := HGET($seen, ob)) => e
1781
1782            PAIRP ob =>
1783                qcar := QCAR ob
1784                qcdr := QCDR ob
1785                (qcar = function newGoGet) =>
1786                    writifyInner replaceGoGetSlot qcdr
1787                (name := spadClosure? ob) =>
1788                   d := writifyInner qcdr
1789                   nob := ['WRITIFIED_!_!, 'SPADCLOSURE, d, name]
1790                   HPUT($seen, ob, nob)
1791                   HPUT($seen, nob, nob)
1792                   nob
1793                (ob is ['LAMBDA_-CLOSURE, ., ., x, :.]) and x =>
1794                  THROW('writifyTag, 'writifyFailed)
1795                nob := CONS(qcar, qcdr)
1796                HPUT($seen, ob, nob)
1797                HPUT($seen, nob, nob)
1798                qcar := writifyInner qcar
1799                qcdr := writifyInner qcdr
1800                QRPLACA(nob, qcar)
1801                QRPLACD(nob, qcdr)
1802                nob
1803            VECP ob =>
1804                isDomainOrPackage ob =>
1805                    d := mkEvalable devaluate ob
1806                    nob := ['WRITIFIED_!_!, 'DEVALUATED, writifyInner d]
1807                    HPUT($seen, ob, nob)
1808                    HPUT($seen, nob, nob)
1809                    nob
1810                n   := QVMAXINDEX ob
1811                nob := MAKE_VEC(n + 1)
1812                HPUT($seen, ob, nob)
1813                HPUT($seen, nob, nob)
1814                for i in 0..n repeat
1815                    QSETVELT(nob, i, writifyInner QVELT(ob,i))
1816                nob
1817            GENERAL_ARRAY?(ob) =>
1818                dims := ARRAY_-DIMENSIONS(ob)
1819                nob := MAKE_-ARRAY(dims)
1820                HPUT($seen, ob, nob)
1821                HPUT($seen, nob, nob)
1822                n := ARRAY_-TOTAL_-SIZE(ob)
1823                for i in 0..(n - 1) repeat
1824                    SETF(ROW_-MAJOR_-AREF(nob, i),
1825                         writifyInner(ROW_-MAJOR_-AREF(ob, i)))
1826                nob
1827            is_BVEC(ob) => ob
1828            STRINGP ob =>
1829                EQ(ob, $NullStream) => ['WRITIFIED_!_!, 'NULLSTREAM]
1830                EQ(ob, $NonNullStream) => ['WRITIFIED_!_!, 'NONNULLSTREAM]
1831                ob
1832            ARRAYP(ob) =>
1833                tt := get_type_tag(ARRAY_-ELEMENT_-TYPE(ob))
1834                tt =>
1835                    dims := ARRAY_-DIMENSIONS(ob)
1836                    n := ARRAY_-TOTAL_-SIZE(ob)
1837                    nv := MAKE_VEC(n)
1838                    nob := ['WRITIFIED_!_!, 'TYARR, tt, dims, nv]
1839                    HPUT($seen, ob, nob)
1840                    HPUT($seen, nob, nob)
1841                    for i in 0..(n - 1) repeat
1842                        QSETVELT(nv, i,
1843                            writifyInner(ROW_-MAJOR_-AREF(ob, i)))
1844                    nob
1845                THROW('writifyTag, 'writifyFailed)
1846            SPAD_KERNEL_-P ob =>
1847                nob := makeSpadKernel(NIL, NIL, SPAD_KERNEL_-NEST(ob))
1848                HPUT($seen, ob, nob)
1849                HPUT($seen, nob, nob)
1850                SETF(SPAD_KERNEL_-OP(nob), _
1851                     writifyInner SPAD_KERNEL_-OP(ob))
1852                SETF(SPAD_KERNEL_-ARG(nob), _
1853                     writifyInner SPAD_KERNEL_-ARG(ob))
1854                nob
1855            ob = 'WRITIFIED_!_! =>
1856                ['WRITIFIED_!_!, 'SELF]
1857            -- In CCL constructors are also compiled functions, so we
1858            -- need this line:
1859            constructor? ob => ob
1860            COMPILED_-FUNCTION_-P ob =>
1861                THROW('writifyTag, 'writifyFailed)
1862            HASHTABLEP ob =>
1863                nob := ['WRITIFIED_!_!]
1864                HPUT($seen, ob,  nob)
1865                HPUT($seen, nob, nob)
1866                keys := HKEYS ob
1867                QRPLACD(nob,
1868                        ['HASHTABLE,
1869                          HASHTABLE_CLASS(ob),
1870                            writifyInner keys,
1871                              [writifyInner HGET(ob,k) for k in keys]])
1872                nob
1873            PLACEP ob =>
1874                nob := ['WRITIFIED_!_!, 'PLACE]
1875                HPUT($seen, ob,  nob)
1876                HPUT($seen, nob, nob)
1877                nob
1878            -- The next three types cause an error on de-writifying.
1879            -- Create an object of the right shape, nonetheless.
1880            READTABLEP ob =>
1881                THROW('writifyTag, 'writifyFailed)
1882            FLOATP ob =>
1883                ob = READ_-FROM_-STRING STRINGIMAGE ob => ob
1884                ['WRITIFIED_!_!, 'FLOAT, ob,:
1885                   MULTIPLE_-VALUE_-LIST INTEGER_-DECODE_-FLOAT ob]
1886            -- Default case: return the object itself.
1887            ob
1888
1889
1890unwritable? ob ==
1891    -- first for speed
1892    PAIRP(ob) => false
1893    EQ(ob, $NullStream) or EQ(ob, $NonNullStream) => true
1894    -- writable arrays
1895    VECP(ob) or GENERAL_ARRAY?(ob) or STRINGP(ob) or is_BVEC(ob) => false
1896    -- other arrays are unwritable
1897    ARRAYP(ob) => true
1898    COMPILED_-FUNCTION_-P   ob or HASHTABLEP ob => true
1899    PLACEP ob or READTABLEP ob => true
1900    FLOATP ob => true
1901    false
1902
1903$type_tags := [
1904   ["U8",     ['UNSIGNED_-BYTE, 8]],
1905    ["U16",   ['UNSIGNED_-BYTE, 16]],
1906     ["U32",  ['UNSIGNED_-BYTE, 32]],
1907      ["DF",  'DOUBLE_-FLOAT]]
1908
1909get_type_tag(lt) ==
1910    res := false
1911    for tp in $type_tags while not(res) repeat
1912        ct := tp.1
1913        if SUBTYPEP(lt, ct) and SUBTYPEP(ct, lt) then
1914            res := tp.0
1915    res
1916
1917get_lisp_type(tt) ==
1918    res := false
1919    for tp in $type_tags while not(res) repeat
1920        if tt = tp.0 then
1921            res := tp.1
1922    res
1923
1924-- Create a full isomorphic object which can be saved in a lisplib.
1925-- Note that  dewritify(writify(x))  preserves UEQUALity of hashtables.
1926-- HASHTABLEs go both ways.
1927-- READTABLEs cannot presently be transformed back.
1928
1929writifyComplain s ==
1930   $writifyComplained  = true => nil
1931   $writifyComplained := true
1932   sayKeyedMsg("S2IH0027",[s])
1933
1934spadClosure? ob ==
1935  fun := QCAR ob
1936  not (FUNCTIONP fun) => nil
1937  not (name := BPINAME fun) => nil
1938  name = "WRAPPED" => nil
1939  vec := QCDR ob
1940  not VECP vec => nil
1941  name
1942
1943dewritify ob ==
1944    (not ScanOrPairVec(function is?, ob)
1945            where  is? a == a = 'WRITIFIED_!_!) => ob
1946
1947    $seen : local := MAKE_HASHTABLE('EQ)
1948
1949    dewritifyInner ob where
1950        dewritifyInner ob ==
1951            null ob => nil
1952            e := HGET($seen, ob) => e
1953
1954            PAIRP ob and first ob = 'WRITIFIED_!_! =>
1955                type := ob.1
1956                type = 'SELF =>
1957                    'WRITIFIED_!_!
1958                type = 'BPI =>
1959                    oname := ob.2
1960                    f :=
1961                        -- FIXME: GENSYMMER is nowhere defined
1962                        INTEGERP oname => EVAL GENSYMMER oname
1963                        SYMBOL_-FUNCTION oname
1964                    not COMPILED_-FUNCTION_-P f =>
1965                        error '"A required BPI does not exist."
1966                    #ob > 3 and HASHEQ f ~= ob.3 =>
1967                        error '"A required BPI has been redefined."
1968                    HPUT($seen, ob, f)
1969                    f
1970                type = 'TYARR =>
1971                    lt := get_lisp_type(ob.2)
1972                    nob := MAKE_TYPED_ARRAY(ob.3, lt)
1973                    HPUT($seen, ob, nob)
1974                    HPUT($seen, nob, nob)
1975                    ov := ob.4
1976                    n := ARRAY_-TOTAL_-SIZE(nob)
1977                    for i in 0..(n - 1) repeat
1978                        SETF(ROW_-MAJOR_-AREF(nob, i),
1979                             dewritifyInner(QVELT(ov, i)))
1980                    nob
1981                type = 'HASHTABLE =>
1982                    nob := MAKE_HASHTABLE(ob.2)
1983                    HPUT($seen, ob, nob)
1984                    HPUT($seen, nob, nob)
1985                    for k in ob.3 for e in ob.4 repeat
1986                        HPUT(nob, dewritifyInner k, dewritifyInner e)
1987                    nob
1988                type = 'DEVALUATED =>
1989                    nob := EVAL dewritifyInner ob.2
1990                    HPUT($seen, ob, nob)
1991                    HPUT($seen, nob, nob)
1992                    nob
1993                type = 'SPADCLOSURE =>
1994                    vec := dewritifyInner ob.2
1995                    name := ob.3
1996                    not FBOUNDP name =>
1997                       error STRCONC('"undefined function: ", SYMBOL_-NAME name)
1998                    nob := CONS(SYMBOL_-FUNCTION name, vec)
1999                    HPUT($seen, ob, nob)
2000                    HPUT($seen, nob, nob)
2001                    nob
2002                type = 'PLACE =>
2003                    nob := get_read_placeholder()
2004                    HPUT($seen, ob, nob)
2005                    HPUT($seen, nob, nob)
2006                    nob
2007                type = 'READTABLE =>
2008                    error '"Cannot de-writify a read table."
2009                type = 'NULLSTREAM => $NullStream
2010                type = 'NONNULLSTREAM => $NonNullStream
2011                type = 'FLOAT =>
2012                   [fval, signif, expon, sign] := CDDR ob
2013                   fval := SCALE_-FLOAT( FLOAT(signif, fval), expon)
2014                   sign<0 => -fval
2015                   fval
2016                error '"Unknown type to de-writify."
2017
2018            PAIRP ob =>
2019                qcar := QCAR ob
2020                qcdr := QCDR ob
2021                nob  := CONS(qcar, qcdr)
2022                HPUT($seen, ob, nob)
2023                HPUT($seen, nob, nob)
2024                QRPLACA(nob, dewritifyInner qcar)
2025                QRPLACD(nob, dewritifyInner qcdr)
2026                nob
2027            VECP ob =>
2028                n   := QVMAXINDEX ob
2029                nob := MAKE_VEC(n + 1)
2030                HPUT($seen, ob, nob)
2031                HPUT($seen, nob, nob)
2032                for i in 0..n repeat
2033                    QSETVELT(nob, i, dewritifyInner QVELT(ob,i))
2034                nob
2035            GENERAL_ARRAY?(ob) =>
2036                dims := ARRAY_-DIMENSIONS(ob)
2037                nob := MAKE_-ARRAY(dims)
2038                HPUT($seen, ob, nob)
2039                HPUT($seen, nob, nob)
2040                n := ARRAY_-TOTAL_-SIZE(ob)
2041                for i in 0..(n - 1) repeat
2042                    SETF(ROW_-MAJOR_-AREF(nob, i),
2043                         dewritifyInner(ROW_-MAJOR_-AREF(ob, i)))
2044                nob
2045            SPAD_KERNEL_-P(ob) =>
2046                nob := makeSpadKernel(NIL, NIL, SPAD_KERNEL_-NEST(ob))
2047                HPUT($seen, ob, nob)
2048                HPUT($seen, nob, nob)
2049                SETF(SPAD_KERNEL_-OP(nob), _
2050                     dewritifyInner SPAD_KERNEL_-OP(ob))
2051                SETF(SPAD_KERNEL_-ARG(nob), _
2052                     dewritifyInner SPAD_KERNEL_-ARG(ob))
2053                nob
2054            -- Default case: return the object itself.
2055            ob
2056
2057ScanOrPairVec(f, ob) ==
2058    $seen : local := MAKE_HASHTABLE('EQ)
2059
2060    CATCH('ScanOrPairVecAnswer, ScanOrInner(f, ob)) where
2061        ScanOrInner(f, ob) ==
2062            HGET($seen, ob) => nil
2063            PAIRP ob =>
2064                HPUT($seen, ob, true)
2065                ScanOrInner(f, QCAR ob)
2066                ScanOrInner(f, QCDR ob)
2067                nil
2068            VECP ob =>
2069                HPUT($seen, ob, true)
2070                for i in 0..#ob-1 repeat ScanOrInner(f, ob.i)
2071                nil
2072            GENERAL_ARRAY?(ob) =>
2073                HPUT($seen, ob, true)
2074                n := ARRAY_-TOTAL_-SIZE(ob)
2075                for i in 0..(n - 1) repeat
2076                    ScanOrInner(f, ROW_-MAJOR_-AREF(ob, i))
2077                nil
2078            SPAD_KERNEL_-P(ob) =>
2079                ScanOrInner(f, SPAD_KERNEL_-OP(ob))
2080                ScanOrInner(f, SPAD_KERNEL_-ARG(ob))
2081            FUNCALL(f, ob) =>
2082                THROW('ScanOrPairVecAnswer, true)
2083            nil
2084
2085--% )library
2086
2087library(args) ==
2088   $newConlist : local := []
2089   original_directory := GET_-CURRENT_-DIRECTORY()
2090   LOCALDATABASE(args, $options)
2091   extendLocalLibdb($newConlist)
2092   CHDIR(original_directory)
2093   terminateSystemCommand()
2094
2095
2096--% )load
2097
2098load args == loadSpad2Cmd args
2099
2100loadSpad2Cmd args ==
2101    sayKeyedMsg("S2IU0003", nil)
2102    NIL
2103
2104reportCount () ==
2105  centerAndHighlight(" Current Count Settings ",$LINELENGTH,specialChar 'hbar)
2106  SAY " "
2107  sayBrightly [:bright " cache",fillerSpaces(30,'".")," ",$cacheCount]
2108  if $cacheAlist then
2109    for [a,:b] in $cacheAlist repeat
2110      aPart:= linearFormatName a
2111      n:= sayBrightlyLength aPart
2112      sayBrightly concat("     ",aPart," ",fillerSpaces(32-n,'".")," ",b)
2113  SAY " "
2114  sayBrightly [:bright " stream",fillerSpaces(29,'".")," ",$streamCount]
2115
2116--% )nopiles
2117
2118nopiles l == nopilesSpad2Cmd l
2119
2120nopilesSpad2Cmd l ==
2121    null l => setNopiles ("{")
2122    #l > 1 =>
2123       SAY "nopiles takes a single argument"
2124    #l = 0 => setNopiles ("{")
2125    l is [opt] =>
2126       opt = 'brace => setNopiles ("{")
2127       opt = 'parenthesis => setNopiles ("(")
2128       SAY "nopiles only takes 'brace' or 'parenthesis' as an argument"
2129
2130
2131--% )quit
2132
2133pquit() == pquitSpad2Cmd()
2134
2135pquitSpad2Cmd() ==
2136  $quitCommandType :local := 'protected
2137  quitSpad2Cmd()
2138
2139quit() == quitSpad2Cmd()
2140
2141quitSpad2Cmd() ==
2142  $quitCommandType ~= 'protected => leaveScratchpad()
2143  x := UPCASE queryUserKeyedMsg("S2IZ0031",NIL)
2144  MEMQ(STRING2ID_N(x, 1), '(Y YES)) => leaveScratchpad()
2145  sayKeyedMsg("S2IZ0032",NIL)
2146  terminateSystemCommand()
2147
2148leaveScratchpad () == QUIT()
2149
2150--% )read
2151
2152DEFVAR($nopiles, false)
2153
2154read l == readSpad2Cmd l
2155
2156readSpad2Cmd l ==
2157  $InteractiveMode : local := true
2158  quiet := nil
2159  ifthere := nil
2160  for [opt,:.] in $options repeat
2161    fullopt := selectOptionLC(opt,'(quiet test ifthere),'optionError)
2162    fullopt = 'ifthere => ifthere  := true
2163    fullopt = 'quiet   => quiet := true
2164
2165  if null(l) and (ef := $edit_file) and pathnameTypeId(ef) ~= 'SPAD then
2166      l := pathname(ef)
2167  else
2168      l := pathname l
2169  devFTs := '("input" "INPUT" "boot" "BOOT" "lisp" "LISP")
2170  fileTypes :=
2171    $UserLevel = 'interpreter => '("input" "INPUT")
2172    $UserLevel = 'compiler    => '("input" "INPUT")
2173    devFTs
2174  ll := find_file(l, fileTypes)
2175  if null ll then
2176    ifthere => return nil    -- be quiet about it
2177    throwKeyedMsg("S2IL0003",[namestring l])
2178  ll := pathname ll
2179  ft := pathnameType ll
2180  upft := UPCASE ft
2181  null member(upft,fileTypes) =>
2182    fs := namestring l
2183    member(upft,devFTs) => throwKeyedMsg("S2IZ0033",[fs])
2184    throwKeyedMsg("S2IZ0034",[fs])
2185  do_read(ll, quiet, $nopiles)
2186
2187do_read(ll, quiet, pile_mode) ==
2188    $nopiles : local := pile_mode
2189    $edit_file := ll
2190    read_or_compile(quiet, false)
2191    terminateSystemCommand()
2192    spadPrompt()
2193
2194basename(x) == NAMESTRING(PATHNAME_-NAME(x))
2195
2196read_or_compile(quiet, lib) ==
2197    $LISPLIB : local := lib
2198    input_file := make_input_filename($edit_file)
2199    type := PATHNAME_-TYPE(input_file)
2200    type = '"boot" =>
2201        lfile := CONCAT(basename(input_file), '".clisp")
2202        BOOTTOCLC(input_file, lfile)
2203        LOAD(COMPILE_-FILE(lfile))
2204    type = '"lisp" =>
2205        ffile := CONCAT(basename(input_file), ".", $lisp_bin_filetype)
2206        LOAD(FRICAS_COMPILE_FASL(input_file, ffile))
2207    type = '"bbin" => LOAD(input_file)
2208    type = '"input" => ncINTERPFILE(input_file, not(quiet))
2209    spadCompile(input_file)
2210
2211--% )show
2212
2213show l ==
2214  ioHook("startSysCmd", "show")
2215  showSpad2Cmd l
2216  ioHook("endSysCmd", "show")
2217
2218showSpad2Cmd l ==
2219  l = [NIL] => helpSpad2Cmd '(show)
2220  $showOptions : local := '(operations)
2221  if null $options then $options := '((operations))
2222  $e : local := $InteractiveFrame
2223  $env : local := $InteractiveFrame
2224  l is [constr] =>
2225    constr in '(Union Record Mapping) =>
2226      constr = 'Record =>
2227        sayKeyedMsg("S2IZ0044R",[constr, '")show Record(a: Integer, b: String)"])
2228      constr = 'Mapping =>
2229        sayKeyedMsg("S2IZ0044M",NIL)
2230      sayKeyedMsg("S2IZ0045T",[constr, '")show Union(a: Integer, b: String)"])
2231      sayKeyedMsg("S2IZ0045U",[constr, '")show Union(Integer, String)"])
2232    constr is ['Mapping, :.] =>
2233      sayKeyedMsg("S2IZ0044M",NIL)
2234    reportOperations(constr,constr)
2235  reportOperations(l,l)
2236
2237reportOperations(oldArg,u) ==
2238  -- u might be an uppercased version of oldArg
2239  $env:local := [[NIL]]
2240  $eval:local := true           --generate code-- don't just type analyze
2241  $genValue:local := true       --evaluate all generated code
2242  $resolve_level : local := 15
2243  null u => nil
2244  u = $quadSymbol =>
2245     sayBrightly ['"   mode denotes", :bright '"any", "type"]
2246  u = "%" =>
2247    sayKeyedMsg("S2IZ0063",NIL)
2248    sayKeyedMsg("S2IZ0064",NIL)
2249  u isnt ['Record,:.] and u isnt ['Union,:.] and
2250    null(isNameOfType u) and u isnt ['typeOf,.] =>
2251      if ATOM oldArg then oldArg := [oldArg]
2252      sayKeyedMsg("S2IZ0063",NIL)
2253      for op in oldArg repeat
2254        sayKeyedMsg("S2IZ0062",[opOf op])
2255  (v := isDomainValuedVariable u) =>  reportOpsFromUnitDirectly0 v
2256  unitForm:=
2257    atom u => opOf unabbrev u
2258    unabbrev u
2259  atom unitForm => reportOpsFromLisplib0(unitForm,u)
2260  unitForm' := evaluateType unitForm
2261  tree := mkAtree removeZeroOneDestructively unitForm
2262  (unitForm' := isType tree) => reportOpsFromUnitDirectly0 unitForm'
2263  sayKeyedMsg("S2IZ0041",[unitForm])
2264
2265reportOpsFromUnitDirectly0 D ==
2266  $useEditorForShowOutput =>
2267    reportOpsFromUnitDirectly1 D
2268  reportOpsFromUnitDirectly D
2269
2270reportOpsFromUnitDirectly1 D ==
2271  showFile := pathname ['SHOW,'LISTING]
2272  erase_lib([showFile])
2273  $sayBrightlyStream : fluid := MAKE_OUTSTREAM(showFile)
2274  sayShowWarning()
2275  reportOpsFromUnitDirectly D
2276  SHUT $sayBrightlyStream
2277  editFile showFile
2278
2279sayShowWarning() ==
2280  sayBrightly
2281    '"Warning: this is a temporary file and will be deleted the next"
2282  sayBrightly
2283    '"         time you use )show. Rename it and FILE if you wish to"
2284  sayBrightly
2285    '"         save the contents."
2286  sayBrightly '""
2287
2288reportOpsFromLisplib0(unitForm,u)  ==
2289  $useEditorForShowOutput => reportOpsFromLisplib1(unitForm,u)
2290  reportOpsFromLisplib(unitForm,u)
2291
2292reportOpsFromLisplib1(unitForm,u)  ==
2293  showFile := pathname ['SHOW,'LISTING]
2294  erase_lib([showFile])
2295  $sayBrightlyStream : fluid := MAKE_OUTSTREAM(showFile)
2296  sayShowWarning()
2297  reportOpsFromLisplib(unitForm,u)
2298  SHUT $sayBrightlyStream
2299  editFile showFile
2300
2301reportOpsFromUnitDirectly unitForm ==
2302  isRecordOrUnion := unitForm is [a,:.] and a in '(Record Union)
2303  unit:= evalDomain unitForm
2304  [top, :argl] := unitForm
2305  kind:= GETDATABASE(top,'CONSTRUCTORKIND)
2306
2307  sayBrightly concat('%b,formatOpType unitForm,
2308    '%d,'"is a",'%b,kind,'%d, '"constructor.")
2309  if not isRecordOrUnion then
2310    abb := GETDATABASE(top,'ABBREVIATION)
2311    sourceFile := GETDATABASE(top,'SOURCEFILE)
2312    sayBrightly ['" Abbreviation for",:bright top,'"is",:bright abb]
2313    verb :=
2314      isExposedConstructor top => '"is"
2315      '"is not"
2316    sayBrightly ['" This constructor",:bright verb,
2317      '"exposed in this frame."]
2318    -- -- Disabled because the path is wrong.
2319    -- sayBrightly ['" Issue",:bright STRCONC('")edit ",
2320    --  namestring sourceFile),'"to see algebra source code for",
2321    --    :bright abb,'%l]
2322
2323  for [opt] in $options repeat
2324    opt := selectOptionLC(opt,$showOptions,'optionError)
2325    opt = 'operations =>
2326      if isRecordOrUnion
2327        then
2328          constructorFunction := get_oplist_maker(top) or
2329            systemErrorHere '"reportOpsFromUnitDirectly"
2330          [funlist,.]:= FUNCALL(constructorFunction,"$",unitForm,
2331            $CategoryFrame)
2332          sigList := REMDUP MSORT [[[a,b],true,[c,0,1]] for
2333            [a,b,c] in funlist]
2334        else
2335          sigList:= REMDUP MSORT getOplistForConstructorForm unitForm
2336
2337      $commentedOps: local := 0
2338      ops := nil
2339
2340      if kind = 'category then
2341        sigList := EQSUBSTLIST(argl,$FormalMapVariableList, sigList)
2342        ops := [formatOperationWithPred(x) for x in sigList]
2343      else
2344        $predicateList: local := GETDATABASE(top, 'PREDICATES)
2345        -- x.1 is the type predicate of operation x
2346        sigList := [x for x in sigList | evalDomainOpPred(unit, x.1)]
2347        -- first(first(x)) is the name of operation x
2348        numOfNames := # REMDUP [first(first(x)) for x in sigList]
2349        sayBrightly ['" ", numOfNames, '" Names for ", #sigList,
2350                     '" Operations in this Domain."]
2351
2352        --new form is (<op> <signature> <slotNumber> <condition> <kind>)
2353        ops := [formatOperation(x, unit) for x in sigList]
2354
2355      centerAndHighlight('"Operations", $LINELENGTH, specialChar 'hbar)
2356      sayBrightly '""
2357      say2PerLine ops
2358
2359      if $commentedOps ~= 0 then
2360        sayBrightly
2361          ['"Functions that are not yet implemented are preceded by",
2362            :bright '"--"]
2363        sayBrightly '""
2364  NIL
2365
2366reportOpsFromLisplib(op,u) ==
2367  null(fn:= constructor? op) => sayKeyedMsg("S2IZ0054",[u])
2368  argml :=
2369    (s := getConstructorSignature op) => IFCDR s
2370    NIL
2371  typ:= GETDATABASE(op,'CONSTRUCTORKIND)
2372  nArgs:= #argml
2373  nArgs = 0 and typ = 'domain =>
2374      reportOpsFromUnitDirectly0 isType mkAtree evaluateType [op]
2375  argList := IFCDR GETDATABASE(op, 'CONSTRUCTORFORM)
2376  functorForm:= [op,:argList]
2377  argml:= EQSUBSTLIST(argList,$FormalMapVariableList,argml)
2378  functorFormWithDecl:= [op,:[[":",a,m] for a in argList for m in argml]]
2379  sayBrightly concat(bright form2StringWithWhere functorFormWithDecl,
2380                     '"is a",bright typ,'"constructor")
2381  sayBrightly ['" Abbreviation for",:bright op,'"is",:bright fn]
2382  verb :=
2383    isExposedConstructor op => '"is"
2384    '"is not"
2385  sayBrightly ['" This constructor",:bright verb,
2386    '"exposed in this frame."]
2387  sourceFile := GETDATABASE(op,'SOURCEFILE)
2388  -- -- Disabled because the path is wrong.
2389  -- sayBrightly ['" Issue",:bright STRCONC('")edit ",
2390  --  namestring sourceFile),
2391  --    '"to see algebra source code for",:bright fn,'%l]
2392
2393  for [opt] in $options repeat
2394    opt := selectOptionLC(opt,$showOptions,'optionError)
2395    opt = 'layout =>
2396      dc1 fn
2397    opt = 'views => sayBrightly ['"To get",:bright '"views",
2398      '"you must give parameters of constructor"]
2399    opt = 'operations => displayOperationsFromLisplib functorForm
2400    nil
2401
2402displayOperationsFromLisplib form ==
2403  [name,:argl] := form
2404  kind := GETDATABASE(name,'CONSTRUCTORKIND)
2405  centerAndHighlight('"Operations",$LINELENGTH,specialChar 'hbar)
2406  sayBrightly '""
2407  opList:= GETDATABASE(name,'OPERATIONALIST)
2408  null opList => nil
2409  opl:=REMDUP MSORT EQSUBSTLIST(argl,$FormalMapVariableList,opList)
2410  ops:= nil
2411  for x in opl repeat
2412    ops := [:ops,:formatOperationAlistEntry(x)]
2413  say2PerLine ops
2414  nil
2415
2416--% )spool
2417
2418spool(filename) ==
2419    null(filename) =>
2420        DRIBBLE()
2421        TERPRI()
2422        reset_highlight()
2423    filename := first(filename)
2424    if SYMBOLP(filename) then filename := SYMBOL_-NAME(filename)
2425    PROBE_-FILE(filename) =>
2426        ERROR(FORMAT(nil, '"file ~a already exists", filename))
2427    DRIBBLE(filename)
2428    TERPRI()
2429    clear_highlight()
2430
2431--% )synonym
2432
2433synonym(:l) == synonymSpad2Cmd()  -- always passed a null list
2434
2435synonymSpad2Cmd() ==
2436  line := getSystemCommandLine()
2437  if line = '"" then printSynonyms(NIL)
2438  else
2439    pair := processSynonymLine line
2440    if $CommandSynonymAlist then
2441      PUTALIST($CommandSynonymAlist, first pair, rest pair)
2442    else $CommandSynonymAlist := [pair]
2443  terminateSystemCommand()
2444
2445processSynonymLine line ==
2446  key := STRING2ID_N (line, 1)
2447  value := removeKeyFromLine line where
2448    removeKeyFromLine line ==
2449      line := dropLeadingBlanks line
2450      mx := MAXINDEX line
2451      for i in 0..mx repeat
2452        line.i = " " =>
2453          return (for j in (i+1)..mx repeat
2454            line.j ~= " " => return (SUBSTRING (line, j, nil)))
2455  [key, :value]
2456
2457
2458--%
2459--% )undo
2460--%
2461
2462$undoFlag := true     --Default setting for undo is "on"
2463
2464
2465undo(l) ==
2466--undo takes one option ")redo" which simply reads "redo.input",
2467--  a file created by every normal )undo command (see below)
2468  undoWhen := 'after
2469  if $options is [[key]] then
2470    stringPrefix?(s := PNAME key,'"redo") =>
2471      $options := nil           --clear $options so that "read" won't see them
2472      read '(redo_.input)
2473    not stringPrefix?(s,'"before") =>
2474       userError '"only option to undo is _")redo_""
2475    undoWhen := 'before
2476  n :=
2477    null l => -1
2478    first l
2479  if IDENTP n then
2480    n := PARSE_-INTEGER PNAME n
2481    if not FIXP n then userError '"undo argument must be an integer"
2482  $InteractiveFrame := undoSteps(undoCount n,undoWhen)
2483  nil
2484
2485recordFrame(systemNormal) ==
2486  null $undoFlag => nil        --do nothing if facility is turned off
2487  currentAlist := IFCAR $frameRecord
2488  delta := diffAlist(CAAR $InteractiveFrame,$previousBindings)
2489  if systemNormal = 'system then
2490    null delta => return nil     --do not record
2491    delta := ['systemCommand,:delta]
2492  $frameRecord := [delta,:$frameRecord]
2493  $previousBindings := --copy all but the individual properties
2494      [CONS(first x, [CONS(first y, rest y) for y in rest x]) for x
2495        in CAAR $InteractiveFrame]
2496  first $frameRecord
2497
2498diffAlist(new,old) ==
2499--record only those properties which are different
2500  for (pair := [name,:proplist]) in new repeat
2501    -- name has an entry both in new and old world
2502    -- (1) if the old world had no proplist for that variable, then
2503    --     record NIL as the value of each new property
2504    -- (2) if the old world does have a proplist for that variable, then
2505    --     a) for each property with a value: give the old value
2506    --     b) for each property missing:      give NIL as the old value
2507    oldPair := ASSQ(name,old) =>
2508      null (oldProplist := rest oldPair) =>
2509      --record old values of new properties as NIL
2510        acc := [[name,:[[prop] for [prop,:.] in proplist]],:acc]
2511      deltas := nil
2512      for (propval := [prop,:val]) in proplist repeat
2513        null (oldPropval := assoc(prop,oldProplist)) => --missing property
2514          deltas := [[prop],:deltas]
2515        EQ(rest oldPropval, val) => 'skip
2516        deltas := [oldPropval,:deltas]
2517      deltas => acc := [[name,:NREVERSE deltas],:acc]
2518    acc := [[name,:[[prop] for [prop,:.] in proplist]],:acc]
2519--record properties absent on new list (say, from a )cl all)
2520  for (oldPair := [name,:r]) in old repeat
2521    r and null QLASSQ(name, new) =>
2522      acc := [oldPair,:acc]
2523    -- name has an entry both in new and old world
2524    -- (1) if the new world has no proplist for that variable
2525    --     (a) if the old world does, record the old proplist
2526    --     (b) if the old world does not, record nothing
2527    -- (2) if the new world has a proplist for that variable, it has
2528    --     been handled by the first loop.
2529  res := NREVERSE acc
2530  if BOUNDP '$reportUndo and $reportUndo then reportUndo res
2531  res
2532
2533reportUndo acc ==
2534  for [name,:proplist] in acc repeat
2535    sayBrightly STRCONC("Properties of ",PNAME name,'" ::")
2536    curproplist := LASSOC(name,CAAR $InteractiveFrame)
2537    for [prop,:value] in proplist repeat
2538      sayBrightlyNT ['"  ",prop,'" was: "]
2539      pp value
2540      sayBrightlyNT ['"  ",prop,'" is:  "]
2541      pp LASSOC(prop,curproplist)
2542
2543clearFrame() ==
2544  clearCmdAll()
2545  $frameRecord := nil
2546  $previousBindings := nil
2547
2548
2549--=======================================================================
2550--              Undoing previous m commands
2551--=======================================================================
2552undoCount(n) ==  --computes the number of undo's, given $IOindex
2553  m :=
2554    n >= 0 => $IOindex - n - 1
2555    -n
2556  m >= $IOindex => userError STRCONC('"Magnitude of undo argument must be less than step number (",STRINGIMAGE $IOindex,'").")
2557  m
2558
2559
2560undoSteps(m,beforeOrAfter) ==
2561-- undoes m previous commands; if )before option, then undo one extra at end
2562--Example: if $IOindex now is 6 and m = 2 then general layout of $frameRecord,
2563--  after the call to recordFrame below will be:
2564--  (<change for systemcommands>
2565--  (<change for #5> <change for system commands>
2566--  (<change for #4> <change for system commands>
2567--  (<change for #3> <change for system commands>
2568--   <change for #2> <change for system commands>
2569--   <change for #1> <change for system commands>) where system
2570--  command entries are optional and identified by (systemCommand . change).
2571--  For a ")undo 3 )after", m = 2 and undoStep swill restore the environment
2572--  up to, but not including <change for #3>.
2573--  An "undo 3 )before" will additionally restore <change for #3>.
2574--  Thus, the later requires one extra undo at the end.
2575  writeInputLines('redo,$IOindex - m)
2576  recordFrame('normal)  --do NOT mark this as a system command change
2577                       --do this undo FIRST (i=0 case)
2578  env := COPY CAAR $InteractiveFrame
2579  for i in 0..m for framelist in tails $frameRecord repeat
2580    env := undoSingleStep(first framelist,env)
2581    framelist is [.,['systemCommand,:systemDelta],:.] =>
2582       framelist := rest framelist             --undoing system commands given
2583       env := undoSingleStep(systemDelta,env)  --  before command line
2584    lastTailSeen := framelist
2585  if beforeOrAfter = 'before then  --do one additional undo for )before
2586    env := undoSingleStep(first rest lastTailSeen,env)
2587  $frameRecord := rest $frameRecord --flush the effect of extra recordFrame
2588  $InteractiveFrame := LIST LIST env
2589
2590
2591undoSingleStep(changes,env) ==
2592--Each change is a name-proplist pair. For each change:
2593--  (1) if there exists a proplist in env, then for each prop-value change:
2594--      (a) if the prop exists in env, RPLAC in the change value
2595--      (b) otherwise, CONS it onto the front of prop-values for that name
2596--  (2) add change to the front of env
2597--  pp '"----Undoing 1 step--------"
2598--  pp changes
2599  for (change := [name,:changeList]) in changes repeat
2600    if LASSOC('localModemap,changeList) then
2601      changeList := undoLocalModemapHack changeList
2602    pairlist := ASSQ(name,env) =>
2603      proplist := rest pairlist =>
2604        for (pair := [prop,:value]) in changeList repeat
2605          node := ASSQ(prop,proplist) => RPLACD(node,value)
2606          RPLACD(proplist, [first proplist, :rest proplist])
2607          RPLACA(proplist,pair)
2608      RPLACD(pairlist,changeList)
2609    env := [change,:env]
2610  env
2611
2612undoLocalModemapHack changeList ==
2613  [newPair for (pair := [name,:value]) in changeList | newPair] where newPair  ==
2614     name = 'localModemap => [name]
2615     pair
2616
2617removeUndoLines u == --called by writeInputLines
2618  xtra :=
2619    STRINGP $currentLine => [$currentLine]
2620    REVERSE $currentLine
2621  xtra := [x for x in xtra | not stringPrefix?('")history",x)]
2622  u := [:u, :xtra]
2623  not (or/[stringPrefix?('")undo",x) for x in u])  => u
2624  --(1) reverse the list
2625  --(2) walk down the (reversed) list: when >n appears remove:
2626  --    (a) system commands
2627  --    (b) if n > 0: (replace n by n-1; remove a command; repeat (a-b))
2628  savedIOindex := $IOindex  --save value
2629  $IOindex := 1
2630  for y in tails u repeat
2631    (x := first y).0 = char '_) =>
2632      stringPrefix?('")undo",s := trimString x) => --parse "undo )option"
2633        s1 := trimString SUBSTRING(s,5,nil)
2634        if s1 ~= '")redo" then
2635          m := charPosition(char '_),s1,0)
2636          code :=
2637            m < MAXINDEX s1 => s1.(m + 1)
2638            char 'a
2639          s2 := trimString SUBSTRING(s1,0,m)
2640        n :=
2641           s1 = '")redo" => 0
2642           s2 ~= '"" => undoCount PARSE_-INTEGER s2
2643           -1
2644        RPLACA(y,CONCAT('">",code,STRINGIMAGE n))
2645      nil
2646    $IOindex := $IOindex + 1   --referenced by undoCount
2647  acc := nil
2648  for y in tails NREVERSE u repeat
2649    (x := first y).0 = char '_> =>
2650      code := x . 1                                 --code = a,b, or r
2651      n := PARSE_-INTEGER SUBSTRING(x,2,nil)        --n = number of undo steps
2652      y := rest y                                   --kill >n line
2653      while y repeat
2654        c := first y
2655        c.0 = char '_) or c.0 = char '_> => y := rest y  --kill system commands
2656        n = 0 => return nil                              --including undos
2657        n := n - 1
2658        y := rest y                                 --kill command
2659      y and code~= char 'b => acc := [c,:acc]       --add last unless )before
2660    acc := [x,:acc]
2661  $IOindex := savedIOindex
2662  acc
2663
2664
2665
2666
2667--% )what
2668
2669
2670what l ==
2671  ioHook("startSysCmd", "what")
2672  whatSpad2Cmd l
2673  ioHook("endSysCmd", "what")
2674
2675whatSpad2Cmd l ==
2676  $e:local := $EmptyEnvironment
2677  null l => reportWhatOptions()
2678  [key0,:args] := l
2679  key := selectOptionLC(key0,$whatOptions,nil)
2680  null key => sayKeyedMsg("S2IZ0043",NIL)
2681  args := [fixpat p for p in args] where
2682    fixpat x ==
2683      x is [x',:.] => DOWNCASE x'
2684      DOWNCASE x
2685  key = 'things =>
2686    for opt in $whatOptions repeat
2687      not MEMQ(opt,'(things)) => whatSpad2Cmd [opt,:args]
2688  key = 'categories =>
2689    filterAndFormatConstructors('category,'"Categories",args)
2690  key = 'commands =>
2691    whatCommands(args)
2692  key = 'domains =>
2693    filterAndFormatConstructors('domain,'"Domains",args)
2694  key = 'operations =>
2695    apropos args
2696  key = 'packages =>
2697    filterAndFormatConstructors('package,'"Packages",args)
2698  key = 'synonyms =>
2699    printSynonyms(args)
2700
2701filterAndFormatConstructors(constrType,label,patterns) ==
2702  centerAndHighlight(label,$LINELENGTH,specialChar 'hbar)
2703  l := filterListOfStringsWithFn(patterns,whatConstructors constrType,
2704        function rest)
2705  if patterns then
2706    null l =>
2707      sayMessage ['"   No ",label,'" with names matching patterns:",
2708        '%l,'"   ",'%b,:blankList patterns,'%d]
2709    sayMessage [label,'" with names matching patterns:",
2710      '%l,'"   ",'%b,:blankList patterns,'%d]
2711  l => pp2Cols l
2712
2713whatConstructors constrType ==
2714  -- here constrType should be one of 'category, 'domain, 'package
2715  MSORT [CONS(GETDATABASE(con,'ABBREVIATION), STRING(con))
2716    for con in allConstructors()
2717      | GETDATABASE(con,'CONSTRUCTORKIND) = constrType]
2718
2719apropos l ==
2720  -- l is a list of operation name fragments
2721  -- this displays all operation names containing these fragments
2722  ops :=
2723    null l => allOperations()
2724    filterListOfStrings([(DOWNCASE STRINGIMAGE p) for p in l],allOperations())
2725  ops =>
2726    sayMessage '"Operations whose names satisfy the above pattern(s):"
2727    sayAsManyPerLineAsPossible MSORT ops
2728    sayKeyedMsg("S2IF0011",[first ops])
2729  sayMessage '"   There are no operations containing those patterns"
2730  NIL
2731
2732
2733printSynonyms(patterns) ==
2734  centerAndHighlight("System Command Synonyms",$LINELENGTH,specialChar 'hbar)
2735  ls := filterListOfStringsWithFn(patterns, [[STRINGIMAGE a,:b]
2736    for [a,:b] in synonymsForUserLevel $CommandSynonymAlist],
2737      function first)
2738  printLabelledList(ls,'"user",'"synonyms",'")",patterns)
2739  nil
2740
2741printLabelledList(ls,label1,label2,prefix,patterns) ==
2742  -- prefix goes before each element on each side of the list, eg,
2743  --   ")"
2744  null ls =>
2745    null patterns =>
2746      sayMessage ['"   No ",label1,'"-defined ",label2,'" in effect."]
2747    sayMessage ['"   No ",label1,'"-defined ",label2,'" satisfying patterns:",
2748     '%l,'"     ",'%b,:blankList patterns,'%d]
2749  if patterns then
2750    sayMessage [label1,'"-defined ",label2,'" satisfying patterns:",
2751     '%l,'"   ",'%b,:blankList patterns,'%d]
2752  for [syn,:comm] in ls repeat
2753    if SUBSTRING(syn,0,1) = '"|" then syn := SUBSTRING(syn,1,NIL)
2754    if syn = '"%i" then syn := '"%i "
2755    wid := MAX(30 - (entryWidth syn),1)
2756    sayBrightly concat('%b,prefix,syn,'%d,
2757      fillerSpaces(wid,'"."),'" ",prefix,comm)
2758  sayBrightly '""
2759
2760whatCommands(patterns) ==
2761  label := STRCONC("System Commands for User Level: ",
2762    STRINGIMAGE $UserLevel)
2763  centerAndHighlight(label,$LINELENGTH,specialChar 'hbar)
2764  l := filterListOfStrings(patterns,
2765    [(STRINGIMAGE a) for a in commandsForUserLevel $systemCommands])
2766  if patterns then
2767    null l =>
2768      sayMessage ['"No system commands at this level matching patterns:",
2769        '%l,'"   ",'%b,:blankList patterns,'%d]
2770    sayMessage ['"System commands at this level matching patterns:",
2771      '%l,'"   ",'%b,:blankList patterns,'%d]
2772  if l then
2773    sayAsManyPerLineAsPossible l
2774    SAY " "
2775  patterns => nil  -- don't be so verbose
2776  sayKeyedMsg("S2IZ0046",NIL)
2777  nil
2778
2779reportWhatOptions() ==
2780  optList1:= "append"/[['%l,'"        ",x] for x in $whatOptions]
2781  sayBrightly
2782    ['%b,'"  )what",'%d,'"argument keywords are",'%b,:optList1,'%d,'%l,
2783      '"   or abbreviations thereof.",'%l,
2784        '%l,'"   Issue",'%b,'")what ?",'%d,'"for more information."]
2785
2786filterListOfStrings(patterns,names) ==
2787  -- names and patterns are lists of strings
2788  -- returns: list of strings in names that contains any of the strings
2789  -- in patterns
2790  (null patterns) or (null names) => names
2791  names' := NIL
2792  for name in reverse names repeat
2793    satisfiesRegularExpressions(name,patterns) =>
2794      names' := [name,:names']
2795  names'
2796
2797filterListOfStringsWithFn(patterns,names,fn) ==
2798  -- names and patterns are lists of strings
2799  -- fn is something like first or CADR
2800  -- returns: list of strings in names that contains any of the strings
2801  -- in patterns
2802  (null patterns) or (null names) => names
2803  names' := NIL
2804  for name in reverse names repeat
2805    satisfiesRegularExpressions(FUNCALL(fn,name),patterns) =>
2806      names' := [name,:names']
2807  names'
2808
2809satisfiesRegularExpressions(name,patterns) ==
2810  -- this is a first cut
2811  nf := true
2812  dname := DOWNCASE COPY name
2813  for pattern in patterns while nf repeat
2814    -- use @ as a wildcard
2815    STRPOS(pattern,dname,0,'"@") => nf := nil
2816  null nf
2817
2818--% Synonym File Reader
2819
2820--------------------> NEW DEFINITION (override in util.lisp)
2821processSynonyms() ==
2822  p := STRPOS('")",LINE,0,NIL)
2823  fill := '""
2824  if p
2825    then
2826      line := SUBSTRING(LINE,p,NIL)
2827      if p > 0 then fill := SUBSTRING(LINE,0,p)
2828    else
2829      p := 0
2830      line := LINE
2831  to := STRPOS ('" ", line, 1, nil)
2832  if to then to := to - 1
2833  synstr := SUBSTRING (line, 1, to)
2834  syn := STRING2ID_N (synstr, 1)
2835  null (fun := LASSOC (syn, $CommandSynonymAlist)) => NIL
2836  to := STRPOS('")",fun,1,NIL)
2837  if to and to ~= SIZE(fun)-1 then
2838    opt := STRCONC('" ",SUBSTRING(fun,to,NIL))
2839    fun := SUBSTRING(fun,0,to-1)
2840  else opt := '" "
2841  if (SIZE synstr) > (SIZE fun) then
2842    for i in (SIZE fun)..(SIZE synstr) repeat
2843      fun := CONCAT (fun, '" ")
2844  cl := STRCONC(fill,RPLACSTR(line, 1, SIZE synstr, fun),opt)
2845  SETQ(LINE,cl)
2846  SETQ(CHR,LINE.(p+1))
2847  processSynonyms ()
2848
2849-- functions for interfacing to system commands from algebra code
2850-- common lisp dependent
2851
2852doSystemCommand string ==
2853   string := CONCAT('")", string)
2854   LINE: fluid := string
2855   processSynonyms()
2856   string := LINE
2857   string:=SUBSTRING(string,1,nil)
2858   string = '"" => nil
2859   tok:=getFirstWord(string)
2860   tok =>
2861        unab := unAbbreviateKeyword tok
2862        member(unab, $noParseCommands) =>
2863          handleNoParseCommands(unab, string)
2864        optionList := splitIntoOptionBlocks string
2865        member(unab, $tokenCommands) =>
2866          handleTokensizeSystemCommands(unab, optionList)
2867        handleParsedSystemCommands(unab, optionList)
2868        nil
2869   nil
2870
2871)if false
2872The system commands given by the global variable
2873[[|$noParseCommands|]]\cite{1} require essentially no
2874preprocessing/parsing of their arguments. Here we dispatch the
2875functions which implement these commands.
2876
2877There are four standard commands which receive arguments -- [[lisp]],
2878[[synonym]], [[system]] and [[boot]]. There are five standard commands
2879which do not receive arguments -- [[quit]], [[fin]], [[pquit]],
2880[[credits]] and [[copyright]]. As these commands do not necessarily
2881exhaust those mentioned in [[|$noParseCommands|]], we provide a
2882generic dispatch based on two conventions: commands which do not
2883require an argument name themselves, those which do have their names
2884prefixed by [[np]].
2885)endif
2886handleNoParseCommands(unab, string) ==
2887  string := stripSpaces string
2888  spaceIndex := SEARCH('" ", string)
2889  unab = "lisp" =>
2890    if (null spaceIndex) then
2891      sayKeyedMsg("S2IV0005", NIL)
2892      nil
2893    else nplisp(stripLisp string)
2894  unab = "boot" =>
2895    if (null spaceIndex) then
2896      sayKeyedMsg("S2IV0005", NIL)
2897      nil
2898    else npboot(SUBSEQ(string, spaceIndex+1))
2899  unab = "system" =>
2900    if (null spaceIndex) then
2901      sayKeyedMsg("S2IV0005", NIL)
2902      nil
2903    else npsystem(unab, string)
2904  unab = "synonym" =>
2905    npsynonym(unab, (null spaceIndex => '""; SUBSEQ(string, spaceIndex+1)))
2906  null spaceIndex =>
2907    FUNCALL unab
2908  member(unab, '( quit     _
2909                  fin      _
2910                  piles    _
2911                  pquit    _
2912                  credits  _
2913                  copyright )) =>
2914    sayKeyedMsg("S2IV0005", NIL)
2915    nil
2916  funName := INTERN CONCAT('"np",STRING unab)
2917  FUNCALL(funName, SUBSEQ(string, spaceIndex+1))
2918
2919string2BootTree(str) == STTOSEX(str)
2920
2921npboot str ==
2922  sex := string2BootTree str
2923  FORMAT(true, '"~&~S~%", sex)
2924  $ans := EVAL sex
2925  FORMAT(true, '"~&Value = ~S~%", $ans)
2926
2927stripLisp str ==
2928  found := false
2929  strIndex := 0
2930  lispStr := '"lisp"
2931  for c0 in 0..#str-1 for c1 in 0..#lispStr-1 repeat
2932    (char str.c0) ~= (char lispStr.c1) =>
2933      return nil
2934    strIndex := c0+1
2935  SUBSEQ(str, strIndex)
2936
2937
2938nplisp str ==
2939  $ans := EVAL READ_-FROM_-STRING str
2940  FORMAT(true, '"~&Value = ~S~%", $ans)
2941
2942intnplisp s ==
2943  $currentLine := s
2944  nplisp $currentLine
2945
2946npsystem(unab, str) ==
2947  spaceIndex := SEARCH('" ", str)
2948  null spaceIndex =>
2949    sayKeyedMsg("S2IZ0080", [str])
2950  sysPart := SUBSEQ(str, 0, spaceIndex)
2951  -- The following is a hack required by the fact that unAbbreviateKeyword
2952  -- returns the word "system" for unknown words
2953  null SEARCH(sysPart, STRING unab) =>
2954    sayKeyedMsg("S2IZ0080", [sysPart])
2955  command := SUBSEQ(str, spaceIndex+1)
2956  OBEY command
2957
2958npsynonym(unab, str) ==
2959  npProcessSynonym(str)
2960
2961tokenSystemCommand(unabr, tokList) ==
2962  systemCommand tokList
2963
2964tokTran tok ==
2965  STRINGP tok =>
2966    #tok = 0 => nil
2967    isIntegerString tok => READ_-FROM_-STRING tok
2968    STRING tok.0 = '"_"" =>
2969      SUBSEQ(tok, 1, #tok-1)
2970    INTERN tok
2971  tok
2972
2973isIntegerString tok ==
2974  for i in 0..#tok-1 repeat
2975    val := DIGIT_-CHAR_-P tok.i
2976    not val => return nil
2977  val
2978
2979splitIntoOptionBlocks str ==
2980  inString := false
2981  optionBlocks := nil
2982  blockStart := 0
2983  parenCount := 0
2984  for i in 0..#str-1 repeat
2985    STRING str.i = '"_"" =>
2986      inString := not inString
2987    if STRING str.i = '"(" and not inString
2988    then parenCount := parenCount + 1
2989    if STRING str.i = '")" and not inString
2990    then parenCount := parenCount - 1
2991    STRING str.i = '")" and not inString and parenCount = -1 =>
2992      block := stripSpaces SUBSEQ(str, blockStart, i)
2993      blockList := [block, :blockList]
2994      blockStart := i+1
2995      parenCount := 0
2996  blockList := [stripSpaces SUBSEQ(str, blockStart), :blockList]
2997  nreverse blockList
2998
2999dumbTokenize str ==
3000  -- split into tokens delimited by spaces, taking quoted strings into account
3001  inString := false
3002  tokenList := nil
3003  tokenStart := 0
3004  previousSpace := false
3005  for i in 0..#str-1 repeat
3006    STRING str.i = '"_"" =>
3007      inString := not inString
3008      previousSpace := false
3009    STRING str.i = '" " and not inString =>
3010      previousSpace => nil
3011      token := stripSpaces SUBSEQ(str, tokenStart, i)
3012      tokenList := [token, :tokenList]
3013      tokenStart := i+1
3014      previousSpace := true
3015    previousSpace := false
3016  tokenList := [stripSpaces SUBSEQ(str, tokenStart), :tokenList]
3017  nreverse tokenList
3018
3019handleParsedSystemCommands(unabr, optionList) ==
3020  restOptionList := [dumbTokenize opt for opt in rest optionList]
3021  parcmd := [parseSystemCmd first optionList,
3022             :[[tokTran tok for tok in opt] for opt in restOptionList]]
3023  systemCommand parcmd
3024
3025parseSystemCmd opt ==
3026  spaceIndex := SEARCH('" ", opt)
3027  spaceIndex =>
3028    commandString := stripSpaces SUBSEQ(opt, 0, spaceIndex)
3029    argString := stripSpaces SUBSEQ(opt, spaceIndex)
3030    command := tokTran commandString
3031    pform := parseFromString argString
3032    [command, pform]
3033  [tokTran tok for tok in dumbTokenize opt]
3034
3035handleTokensizeSystemCommands(unabr, optionList) ==
3036  optionList := [dumbTokenize opt for opt in optionList]
3037  parcmd := [[tokTran tok for tok in opt] for opt in optionList]
3038  parcmd => tokenSystemCommand(unabr, parcmd)
3039
3040getFirstWord string ==
3041  spaceIndex := SEARCH('" ", string)
3042  null spaceIndex => string
3043  stripSpaces SUBSEQ(string, 0, spaceIndex)
3044
3045ltrace l == trace l
3046
3047--------------------> NEW DEFINITION (see intint.lisp)
3048stripSpaces str ==
3049  STRING_-TRIM([char '" "], str)
3050
3051npProcessSynonym(str) ==
3052  if str = '"" then printSynonyms(NIL)
3053  else
3054    pair := processSynonymLine str
3055    if $CommandSynonymAlist then
3056      PUTALIST($CommandSynonymAlist, first pair, rest pair)
3057    else $CommandSynonymAlist := [pair]
3058  terminateSystemCommand()
3059
3060InterpExecuteSpadSystemCommand string ==
3061  CATCH("coerceFailure",
3062    CATCH("SPAD_READER", ExecuteInterpSystemCommand string) )
3063
3064intProcessSynonyms str ==
3065   LINE:local := str
3066   processSynonyms()
3067   LINE
3068
3069ExecuteInterpSystemCommand string ==
3070   string := intProcessSynonyms(string)
3071   $currentLine:local:=string
3072   string:=SUBSTRING(string,1,nil)
3073   string = '"" => nil
3074   doSystemCommand string
3075
3076parseFromString(s) ==
3077   s := next(function ncloopParse,
3078        next(function lineoftoks,incString s))
3079   StreamNull s => nil
3080   pf2Sex macroExpanded first rest first s
3081
3082ncParseFromString(s) ==
3083   $BreakMode : local := 'throw_reader
3084   CATCH('SPAD_READER, parseFromString(s))
3085