src/lib/image.slate

   1
   2 globals define: #Image &builder: [Oddball clone] &slots: {
   3   #filename -> 'slate.image'.
   4 }.
   5
   6 i@Image save &name: filename &startupREPL: startupREPL
   7 "Provides a wrapper over the basic primitive facility to save the heap to a
   8 file. If a filename is not provided, the most recently-used or default
   9 filename is used. The saveImageNamed: primitive saves the stack, and returns
  10 False by default - when a saved-heap is started, the False is replaced with
  11 True, so that a simple boolean check can see if startup actions need to be
  12 performed."
  13 [
  14   startupREPL `defaultsTo: False.
  15   filename
  16     ifNil: [filename := i filename]
  17     ifNotNil: [i filename := filename].
  18   (File newNamed: filename) exists ifTrue:
  19     [warn: 'Saving the image over an existing file: ' ; filename printString ; '.'].
  20   i handleSave.
  21   (isRestarted ::= lobby saveImageNamed: (i filename as: String)) ifTrue:
  22     [startupREPL ifTrue: [repl reset. Abort signal].
  23      i handleStartup].
  24 ].
  25
  26 i@Image saveNamed: filename &startupREPL: startupREPL
  27 [i save &name: filename &startupREPL: startupREPL].
  28
  29 i@Image quit
  30 "Calls the exit primitive after the shutdown hooks."
  31 [
  32   i handleShutdown.
  33   lobby exit: 0.
  34 ].
  35
  36 _@lobby quit [Image quit].
  37
  38 i@Image die
  39 [
  40   i handleShutdown.
  41   lobby exit: 1
  42 ].
  43
  44 "Dictionaries holding actions (blocks taking no argument)
  45 to be performed under various scenarios. Identified by
  46 a descriptive Symbol."
  47 Image define: #startupActions &builder: [Dictionary new].
  48 Image define: #argumentActions &builder: [Dictionary new].
  49 Image define: #shutdownActions &builder: [Dictionary new].
  50 Image define: #saveActions &builder: [Dictionary new].
  51
  52 "these directory functions need image to be defined"
  53 dir@(LogicalDirectory traits) registerStartupHandler
  54 [
  55   [Image startupActions at: dir := [dir locator: Nil]]
  56     on: Error do: [| :c | c return: Nil]
  57 ].
  58
  59 Directory traits define: #Current &builder: [LogicalDirectory newResolving: [Directory current]].
  60
  61 Directory traits define: #Home &builder: [LogicalDirectory newResolving: [Directory home]].
  62
  63 i@Image handleStartup
  64 "Perform each action/block in the startupActions attribute."
  65 [
  66   i startupActions do: [| :action | action on: Abort do: [| :c | c exit]].
  67   i argumentActions do: [| :action | action on: Abort do: [| :c | c exit]]
  68 ].
  69
  70 i@Image handleShutdown
  71 "Perform each action/block in the shutdownActions attribute."
  72 [
  73   i shutdownActions do: [| :action | action on: Abort do: [| :c | c exit]]
  74 ].
  75
  76 i@Image handleSave
  77 "Perform each action/block in the saveActions attribute."
  78 [
  79   i saveActions do: [| :action | action on: Abort do: [| :c | c exit]]
  80 ].
  81
  82 "Invoke the startup method on all dangling ExternalResources when
  83 the image starts up."
  84 Image startupActions at: #ExternalResource :=
  85   [ExternalResource schedule do: #startup `er].
  86
  87 "Invoke the shutdown method on all open ExternalResources when
  88 the image shuts down."
  89 Image shutdownActions at: #ExternalResource :=
  90   [ExternalResource schedule reverseDo: #shutdown `er].
  91
  92 "Refresh the standard LogicalDirectory objects."
  93 [| :dir | Image startupActions at: dir := [dir locator := Nil]]
  94   for: {Directory Home. Directory Current}.
  95
  96 i@Image objectCount
  97 "The number of heap-allocated objects in the current Image."
  98 [(i reader >> 0 writer) value].
  99
 100 _@globals executionArguments
 101 "Answer the arguments that Slate was invoked with, as an Array of Strings."
 102 [
 103   argc ::= lobby vmArgCount.
 104   arguments ::= Array newSize: argc.
 105   0 below: argc do: [| :i | arguments at: i := (lobby vmArg: i) as: String].
 106   arguments as: ExtensibleArray
 107 ].
 108
 109 Image startupActions at: #StartupArguments :=
 110   [globals define: #StartupArguments -> lobby executionArguments].
 111
 112 Image argumentActions at: #StartupArguments :=
 113   [Image handleStandardCommandOptions].
 114
 115 Image define: #StartupArgumentHandlers &builder: [Dictionary new].
 116 Image define: #StartupArgumentDocs &builder: [Dictionary new].
 117
 118 i@Image handleArgument: optionString with: handler
 119 [i StartupArgumentHandlers at: optionString := handler].
 120
 121 i@Image documentArgument: optionString with: docString
 122 [i StartupArgumentDocs at: optionString := docString].
 123
 124 Image handleArgument: '--load' with:
 125   [| :index | lobby load: (StartupArguments at: index + 1)].
 126 Image documentArgument: '--load' with: 'Loads the file named by the following argument'.
 127 Image handleArgument: '--eval' with:
 128   [| :index |
 129    p ::= Syntax Parser newOn: (StartupArguments at: index + 1) reader.
 130    [p isAtEnd] whileFalse: [p next evaluate]].
 131 Image documentArgument: '--eval' with: 'Evaluates the following argument. No magic escaping is done.'.
 132 Image handleArgument: '-c' with:
 133   [| :index | [lobby load: (StartupArguments at: index + 1) &showLoadMessage: False] unlessCompletes: [exit: 1]. quit].
 134 Image documentArgument: '-c' with: 'Loads the file named by the following argument and then quits.'.
 135
 136 i@Image handleStandardCommandOptions
 137 "Handles --load and --eval options from the command-line invocation."
 138 [
 139   (StartupArguments includes: '--image-help')
 140     ifTrue:
 141       [inform: 'This image advertises the following options:'.
 142        i StartupArgumentHandlers keysDo:
 143          [| :opt | inform: opt
 144             ; '\t'
 145             ; (i StartupArgumentDocs at: opt ifAbsent: ['(none provided)'])].
 146        quit]
 147     ifFalse:
 148       ["Implicitly add -c if only called with one argument."
 149        StartupArguments size > 1 /\ [StartupArguments second first ~= $-]
 150          ifTrue: [StartupArguments at: 1 insert: '-c'].
 151        StartupArguments doWithIndex:
 152          [| :arg :index |
 153           (i StartupArgumentHandlers at: arg ifAbsent: [])
 154             ifNotNilDo: [| :handler | handler applyWith: index]]].
 155 ].