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
33)package "BOOT"
34
35--% Various lispy things
36
37MKQ(X) ==
38    NUMBERP(X) => X
39    ['QUOTE, X]
40
41INTERNL1(a, b) == INTERN(CONCAT(a, b))
42
43$GENNO := 0
44
45GENVAR() ==
46    INTERNL1('"$", STRINGIMAGE($GENNO := $GENNO + 1))
47
48contained_eq(x, y) ==
49    ATOM(y) => EQ(x, y)
50    contained_eq(x, first(y)) or contained_eq(x, rest(y))
51
52contained_equal(x, y) ==
53    x = y => true
54    ATOM(y) => false
55    contained_equal(x, first(y)) or contained_equal(x, rest(y))
56
57CONTAINED(x, y) ==
58    SYMBOLP(x) => contained_eq(x, y)
59    contained_equal(x, y)
60
61ELEMN(l, n, def_val) ==
62    for i in 1..(n - 1) repeat
63        NULL(l) => return def_val
64        l := rest(l)
65    NULL(l) => def_val
66    first(l)
67
68LISTOFATOMS1(l, rl) ==
69    NULL(l) => rl
70    ATOM(l) => CONS(l, rl)
71    rl := LISTOFATOMS1(first(l), rl)
72    LISTOFATOMS1(rest(l), rl)
73
74LISTOFATOMS(l) == NREVERSE(LISTOFATOMS1(l, []))
75
76Identity x == x
77
78length1? l == PAIRP l and not PAIRP QCDR l
79
80length2? l == PAIRP l and PAIRP (l := QCDR l) and not PAIRP QCDR l
81
82pairList(u,v) == [[x,:y] for x in u for y in v]
83
84concatenateStringList(l) ==
85    ll := 0
86    for s in l repeat ll := ll + LENGTH(s)
87    result := MAKE_-STRING(ll)
88    ll := 0
89    for s in l repeat
90        replaceString(result, s, ll)
91        ll := ll + LENGTH(s)
92    result
93
94GETL(op, prop) == op and SYMBOLP(op) and GET(op, prop)
95
96GETALIST(alist,prop) == CDR assoc(prop,alist)
97
98PUTALIST(alist,prop,val) ==
99  null alist => [[prop,:val]]
100  pair := assoc(prop,alist) =>
101    CDR pair = val => alist
102    -- else we fall over Lucid's read-only storage feature again
103    QRPLACD(pair,val)
104    alist
105  QRPLACD(LASTNODE alist,[[prop,:val]])
106  alist
107
108REMALIST(alist,prop) ==
109  null alist => alist
110  alist is [[ =prop,:.],:r] =>
111    null r => NIL
112    QRPLACA(alist,CAR r)
113    QRPLACD(alist,CDR r)
114    alist
115  null rest alist => alist
116  l := alist
117  ok := true
118  while ok repeat
119    [.,[p,:.],:r] := l
120    p = prop =>
121      ok := NIL
122      QRPLACD(l,r)
123    if null (l := QCDR l) or null rest l then ok := NIL
124  alist
125
126--% association list functions
127
128deleteAssoc(x,y) ==
129  y is [[a,:.],:y'] =>
130   a=x => deleteAssoc(x,y')
131   [first y,:deleteAssoc(x,y')]
132  y
133
134insertWOC(x,y) ==
135  null y => [x]
136  (fn(x,y); y) where fn(x,y is [h,:t]) ==
137    x=h => nil
138    null t =>
139      RPLACD(y,[h,:t])
140      RPLACA(y,x)
141    fn(x,t)
142
143--% Miscellaneous Functions for Working with Strings
144
145fillerSpaces(n, charPart) ==
146  n <= 0 => '""
147  make_full_CVEC(n, charPart)
148
149centerString(text,width,fillchar) ==
150  wid := entryWidth text
151  wid >= width => text
152  f := DIVIDE(width - wid,2)
153  fill1 := ""
154  for i in 1..(f.0) repeat
155    fill1 := STRCONC(fillchar,fill1)
156  fill2:= fill1
157  if f.1 ~= 0 then fill1 := STRCONC(fillchar,fill1)
158  [fill1,text,fill2]
159
160stringPrefix?(pref,str) ==
161  -- sees if the first #pref letters of str are pref
162  -- replaces STRINGPREFIXP
163  null (STRINGP(pref) and STRINGP(str)) => NIL
164  (lp := QCSIZE pref) = 0 => true
165  lp > QCSIZE str => NIL
166  ok := true
167  i := 0
168  while ok and (i < lp) repeat
169    not EQL(SCHAR(pref,i),SCHAR(str,i)) => ok := NIL
170    i := i + 1
171  ok
172
173dropLeadingBlanks str ==
174  str := object2String str
175  l := QCSIZE str
176  nb := NIL
177  i := 0
178  while (i < l) and not nb repeat
179    if SCHAR(str,i) ~= SCHAR('" ",0) then nb := i
180    else i := i + 1
181  nb = 0 => str
182  nb => SUBSTRING(str,nb,NIL)
183  '""
184
185concat(:l) == concatList l
186
187concatList [x,:y] ==
188  null y => x
189  null x => concatList y
190  concat1(x,concatList y)
191
192concat1(x,y) ==
193  null x => y
194  atom x => (null y => x; atom y => [x,y]; [x,:y])
195  null y => x
196  atom y => [:x,y]
197  [:x,:y]
198
199--% Miscellaneous
200
201freeOfSharpVars x ==
202  atom x => not isSharpVarWithNum x
203  freeOfSharpVars first x and freeOfSharpVars rest x
204
205listOfSharpVars x ==
206  atom x => (isSharpVarWithNum x => LIST x; nil)
207  union(listOfSharpVars first x,listOfSharpVars rest x)
208
209listOfPatternIds x ==
210  isPatternVar x => [x]
211  atom x => nil
212  x is ['QUOTE,:.] => nil
213  UNIONQ(listOfPatternIds first x,listOfPatternIds rest x)
214
215isPatternVar v ==
216  -- a pattern variable consists of a star followed by a star or digit(s)
217  IDENTP(v) and MEMQ(v,'(_*_* _*1 _*2 _*3 _*4 _*5 _*6 _*7 _*8 _*9 _*10
218    _*11 _*12 _*13 _*14 _*15 _*16 _*17 _*18 _*19 _*20)) and true
219
220removeZeroOne x ==
221  -- replace all occurrences of (Zero) and (One) with
222  -- 0 and 1
223  x = $Zero => 0
224  x = $One => 1
225  atom x => x
226  [removeZeroOne first x,:removeZeroOne rest x]
227
228removeZeroOneDestructively t ==
229  -- replace all occurrences of (Zero) and (One) with
230  -- 0 and 1 destructively
231  t = $Zero => 0
232  t = $One => 1
233  atom t => t
234  RPLNODE(t,removeZeroOneDestructively first t,
235    removeZeroOneDestructively rest t)
236
237--% Inplace Merge Sort for Lists
238-- MBM April/88
239
240-- listSort(pred,list) or listSort(pred,list,key)
241-- the pred function is a boolean valued function defining the ordering
242-- the key function extracts the key from an item for comparison by pred
243
244listSort(pred,list,:optional) ==
245   NOT functionp pred => error "listSort: first arg must be a function"
246   NOT LISTP list => error "listSort: second argument must be a list"
247   NULL optional => mergeSort(pred,function Identity,list,LENGTH list)
248   key := CAR optional
249   NOT functionp key => error "listSort: last arg must be a function"
250   mergeSort(pred,key,list,LENGTH list)
251
252-- non-destructive merge sort using NOT GGREATERP as predicate
253MSORT list == listSort(function GLESSEQP, COPY_-LIST list)
254
255-- destructive merge sort using NOT GGREATERP as predicate
256NMSORT list == listSort(function GLESSEQP, list)
257
258-- non-destructive merge sort using ?ORDER as predicate
259orderList l == listSort(function _?ORDER, COPY_-LIST l)
260
261mergeInPlace(f,g,p,q) ==
262   -- merge the two sorted lists p and q
263   if NULL p then return p
264   if NULL q then return q
265   if FUNCALL(f,FUNCALL(g, QCAR p),FUNCALL(g, QCAR q))
266   then (r := t := p; p := QCDR p)
267   else (r := t := q; q := QCDR q)
268   while not NULL p and not NULL q repeat
269      if FUNCALL(f,FUNCALL(g,QCAR p),FUNCALL(g,QCAR q))
270      then (QRPLACD(t,p); t := p; p := QCDR p)
271      else (QRPLACD(t,q); t := q; q := QCDR q)
272   if NULL p then QRPLACD(t,q) else QRPLACD(t,p)
273   r
274
275mergeSort(f,g,p,n) ==
276   if eql_SI(n, 2) and
277        FUNCALL(f, FUNCALL(g, QCADR p), FUNCALL(g, QCAR p)) then
278      t := p
279      p := QCDR p
280      QRPLACD(p,t)
281      QRPLACD(t,NIL)
282   if less_SI(n, 3) then return p
283   -- split the list p into p and q of equal length
284   l := quo_SI(n, 2)
285   t := p
286   for i in 1..l-1 repeat t := QCDR t
287   q := rest t
288   QRPLACD(t,NIL)
289   p := mergeSort(f,g,p,l)
290   q := mergeSort(f, g, q, sub_SI(n, l))
291   mergeInPlace(f,g,p,q)
292
293--% Throwing with glorious highlighting (maybe)
294
295throw_to_reader() == THROW('SPAD_READER, nil)
296
297spadThrow() ==
298  if $interpOnly and $mapName then
299    putHist($mapName,'localModemap, nil, $e)
300  $BreakMode = 'throw_reader => throw_to_reader()
301  handleLispBreakLoop($BreakMode)
302
303spadThrowBrightly x ==
304  sayBrightly x
305  spadThrow()
306
307--% Type Formatting Without Abbreviation
308
309formatUnabbreviatedSig sig ==
310  null sig => ["() -> ()"]
311  [target,:args] := sig
312  target := formatUnabbreviated target
313  null args => ['"() -> ",:target]
314  null rest args => [:formatUnabbreviated QCAR args,'" -> ",:target]
315  args := formatUnabbreviatedTuple args
316  ['"(",:args,'") -> ",:target]
317
318formatUnabbreviatedTuple t ==
319  -- t is a list of types
320  null t => t
321  atom t => [t]
322  t0 := formatUnabbreviated QCAR t
323  null rest t => t0
324  [:t0,'",",:formatUnabbreviatedTuple QCDR t]
325
326formatUnabbreviated t ==
327  atom t =>
328    [t]
329  null t =>
330    ['"()"]
331  t is [p,sel,arg] and p in '(_: ":") =>
332    [sel,'": ",:formatUnabbreviated arg]
333  t is ['Union,:args] =>
334    ['Union,'"(",:formatUnabbreviatedTuple args,'")"]
335  t is ['Mapping,:args] =>
336    formatUnabbreviatedSig args
337  t is ['Record,:args] =>
338    ['Record,'"(",:formatUnabbreviatedTuple args,'")"]
339  t is [arg] =>
340    t
341  t is [arg,arg1] =>
342    [arg,'" ",:formatUnabbreviated arg1]
343  t is [arg,:args] =>
344    [arg,'"(",:formatUnabbreviatedTuple args,'")"]
345  t
346
347sublisNQ(al,e) ==
348  atom al => e
349  fn(al,e) where fn(al,e) ==
350    atom e =>
351      for x in al repeat
352        EQ(first x,e) => return (e := rest x)
353      e
354    EQ(a := first e,'QUOTE) => e
355    u := fn(al,a)
356    v := fn(al,rest e)
357    EQ(a,u) and EQ(rest e,v) => e
358    [u,:v]
359
360opOf x ==
361  atom x => x
362  first x
363
364getProplist(x,E) ==
365  not atom x => getProplist(first x,E)
366  u:= search(x,E) => u
367  (pl:=search(x,$CategoryFrame)) =>
368    pl
369
370search(x,e is [curEnv,:tailEnv]) ==
371  tailEnv =>
372    BREAK()
373  searchCurrentEnv(x,curEnv)
374
375searchCurrentEnv(x,currentEnv) ==
376  for contour in currentEnv repeat
377    if u:= ASSQ(x,contour) then return (signal:= u)
378  IFCDR signal
379
380augProplist(proplist,prop,val) ==
381  $InteractiveMode => augProplistInteractive(proplist,prop,val)
382  while (proplist is [[ =prop,:.],:proplist']) repeat proplist:= proplist'
383  val=(u:= LASSOC(prop,proplist)) => proplist
384  null val =>
385    null u => proplist
386    DELLASOS(prop,proplist)
387  [[prop,:val],:proplist]
388
389augProplistOf(var,prop,val,e) ==
390  proplist:= getProplist(var,e)
391  semchkProplist(var,proplist,prop,val)
392  augProplist(proplist,prop,val)
393
394semchkProplist(x,proplist,prop,val) ==
395  prop="isLiteral" =>
396    LASSOC("value",proplist) or LASSOC("mode",proplist) => warnLiteral x
397  MEMQ(prop,'(mode value)) =>
398    LASSOC("isLiteral",proplist) => warnLiteral x
399
400DEFPARAMETER($envHashTable, nil)
401
402addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) ==
403  EQ(proplist,getProplist(var,e)) => e
404  if $envHashTable then
405    for u in proplist repeat
406      HPUT($envHashTable, [var, CAR u], true)
407  $InteractiveMode => addBindingInteractive(var,proplist,e)
408  if curContour is [[ =var,:.],:.] then curContour:= rest curContour
409                 --Previous line should save some space
410  [[[lx,:curContour],:tailContour],:tailEnv] where lx:= [var,:proplist]
411
412position(x,l) ==
413  posn(x,l,0) where
414    posn(x,l,n) ==
415      null l => -1
416      x=first l => n
417      posn(x,rest l,n+1)
418
419insert(x,y) ==
420  member(x,y) => y
421  [x,:y]
422
423after(u,v) ==
424  r:= u
425  for x in u for y in v repeat r:= rest r
426  r
427
428
429$blank := char ('_ )
430
431trimString s ==
432  leftTrim rightTrim s
433
434leftTrim s ==
435  k := MAXINDEX s
436  k < 0 => s
437  s.0 = $blank =>
438    for i in 0..k while s.i = $blank repeat (j := i)
439    SUBSTRING(s,j + 1,nil)
440  s
441
442rightTrim s ==  -- assumed a non-empty string
443  k := MAXINDEX s
444  k < 0 => s
445  s.k = $blank =>
446    for i in k..0 by -1 while s.i = $blank repeat (j := i)
447    SUBSTRING(s,0,j)
448  s
449
450pp x ==
451  PRETTYPRINT x
452  nil
453
454quickAnd(a,b) ==
455  a = true => b
456  b = true => a
457  a = false or b = false => false
458  simpBool ['AND,a,b]
459
460quickOr(a,b) ==
461  a = true or b = true => true
462  b = false => a
463  a = false => b
464  simpCatPredicate simpBool ['OR,a,b]
465
466intern x ==
467  STRINGP x =>
468    DIGITP x.0 => string2Integer x
469    INTERN x
470  x
471
472-- variables used by browser
473
474$htHash      := MAKE_HASHTABLE('EQUAL)
475$glossHash   := MAKE_HASHTABLE('EQUAL)
476$lispHash    := MAKE_HASHTABLE('EQUAL)
477$sysHash     := MAKE_HASHTABLE('EQUAL)
478$htSystemCommands := '(
479 (boot . development) clear display (fin . development) edit help
480 frame history load quit read set show synonym system
481 trace what )
482$currentSysList := [opOf x for x in $htSystemCommands] --see ht-root
483$outStream   := nil
484$recheckingFlag    := false     --see transformAndRecheckComments
485$exposeFlag        := false     --if true, messages go to $outStream
486$exposeFlagHeading := false     --see htcheck.boot
487$checkingXmptex? := false       --see htcheck.boot
488$exposeDocHeading:= nil         --see htcheck.boot
489$charPlus := char '_+
490$charBlank:= (char '_ )
491$charLbrace:= char '_{
492$charRbrace:= char '_}
493$charBack := char '_\
494$charDash := char '_-
495
496$charTab            := CODE_-CHAR(9)
497$charNewline        := CODE_-CHAR(10)
498$charFauxNewline    := CODE_-CHAR(25)
499$stringNewline      := PNAME CODE_-CHAR(10)
500$stringFauxNewline  := PNAME CODE_-CHAR(25)
501
502$charExclusions := [char 'a, char 'A]
503$charQuote := char '_'
504$charSemiColon := char '_;
505$charComma     := char '_,
506$charPeriod    := char '_.
507$checkPrenAlist := [[char '_(,:char '_)],[char '_{,:char '_}],[char '_[,:char '_]]]
508$charEscapeList:= [char '_%,char '_#,$charBack]
509$charIdentifierEndings := [char '__, char '_!, char '_?]
510$charSplitList := [$charComma,$charPeriod,char '_[, char '_],$charLbrace, $charRbrace, char '_(, char '_), char '_$, char '_%]
511$charDelimiters := [$charBlank, char '_(, char '_), $charBack]
512$HTspadmacros := '("\spadtype" "\spadcommand" "\spadop" "\spadfun" "\spadatt" "\spadsyscom" "\spad" "\s")
513$HTmacs := [
514  ['"\beginmenu",$charRbrace,'"menu",$charLbrace,'"\begin"],
515   ['"\endmenu",$charRbrace,'"menu",$charLbrace,'"\end"],
516     ['"\beginitems",$charRbrace,'"items",$charLbrace,'"\begin"],
517       ['"\enditems",$charRbrace,'"items",$charLbrace,'"\end"],
518         ['"\beginscroll",$charRbrace,'"scroll",$charLbrace,'"\begin"],
519           ['"\endscroll",$charRbrace,'"scroll",$charLbrace,'"\end"]]
520
521$HTlinks := '(
522  "\downlink"
523  "\menulink"
524  "\menudownlink"
525  "\menuwindowlink"
526  "\menumemolink")
527
528$HTlisplinks := '(
529  "\lispdownlink"
530  "\menulispdownlink"
531  "\menulispwindowlink"
532  "\menulispmemolink"
533  "\lispwindowlink"
534  "\lispmemolink")
535
536$beginEndList := '(
537  "page"
538  "items"
539  "menu"
540  "scroll"
541  "verbatim"
542  "detail")
543
544isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) = char '_&
545
546-- from i-util
547
548--% Utility Functions Used Only by the Interpreter
549
550-- A wrapped value represents something that need not be evaluated
551-- when code is generated.  This includes objects from domains or things
552-- that just happed to evaluate to themselves.  Typically generated
553-- lisp code is unwrapped.
554
555wrap x ==
556  isWrapped x => x
557  ['WRAPPED,:x]
558
559isWrapped x == x is ['WRAPPED,:.] or NUMBERP x or FLOATP x or STRINGP x
560
561unwrap x ==
562  NUMBERP x or FLOATP x or STRINGP x => x
563  x is ["WRAPPED",:y] => y
564  x
565
566wrapped2Quote x ==
567  x is ["WRAPPED",:y] => MKQ y
568  x
569
570quote2Wrapped x ==
571  x is ['QUOTE,y] => wrap y
572  x
573
574removeQuote x ==
575  x is ["QUOTE",y] => y
576  x
577
578--% The function for making prompts
579
580spadPrompt() ==
581  SAY '"   FriCAS"
582  sayNewLine()
583
584princPrompt() ==
585  ioHook("startPrompt")
586  PRINC MKPROMPT()
587  ioHook("endOfPrompt")
588
589MKPROMPT() ==
590  $inputPromptType = 'none    => '""
591  $inputPromptType = 'plain   => '"-> "
592  $inputPromptType = 'step    =>
593    STRCONC('"(",STRINGIMAGE $IOindex,'") -> ")
594  $inputPromptType = 'frame   =>
595    STRCONC(STRINGIMAGE $interpreterFrameName,
596      '" (",STRINGIMAGE $IOindex,'") -> ")
597  STRCONC(STRINGIMAGE $interpreterFrameName,
598   '" [", SUBSTRING(CURRENTTIME(),8,NIL),'"] [",
599    STRINGIMAGE $IOindex, '"] -> ")
600
601--% Miscellaneous
602
603-- formerly in clammed.boot
604
605isSubDomain(d1,d2) ==
606  -- d1 and d2 are different domains
607  subDomainList := '(Integer NonNegativeInteger PositiveInteger)
608  ATOM d1 or ATOM d2 => nil
609  l := MEMQ(first d2, subDomainList) =>
610    MEMQ(first d1, rest l)
611  nil
612
613-- functions used at run-time which were formerly in the compiler files
614
615Undef(:u) ==
616  u':= last u
617  [[domain,slot],op,sig]:= u'
618  domain':=eval mkEvalable domain
619  not EQ(first ELT(domain', slot), Undef) =>
620  -- OK - the function is now defined
621    [:u'',.]:=u
622    if $reportBottomUpFlag then
623      sayMessage concat ['"   Retrospective determination of slot",'%b,
624        slot,'%d,'"of",'%b,:prefix2String domain,'%d]
625    APPLY(first ELT(domain', slot), [:u'', rest ELT(domain', slot)])
626  throwKeyedMsg("S2IF0008",[formatOpSignature(op,sig),domain])
627
628TruthP x ==
629    --True if x is a predicate that's always true
630  x is nil => nil
631  x=true => true
632  x is ['QUOTE,:.] => true
633  nil
634