library/tools/listener.factor

   1 ! :folding=indent:collapseFolds=1:
   2
   3 ! $Id$
   4 !
   5 ! Copyright (C) 2003, 2004 Slava Pestov.
   6 !
   7 ! Redistribution and use in source and binary forms, with or without
   8 ! modification, are permitted provided that the following conditions are met:
   9 !
  10 ! 1. Redistributions of source code must retain the above copyright notice,
  11 !    this list of conditions and the following disclaimer.
  12 !
  13 ! 2. Redistributions in binary form must reproduce the above copyright notice,
  14 !    this list of conditions and the following disclaimer in the documentation
  15 !    and/or other materials provided with the distribution.
  16 !
  17 ! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
  18 ! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
  19 ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  20 ! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  21 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
  22 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
  23 ! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  24 ! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  25 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
  26 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  27
  28 IN: listener
  29 USE: errors
  30 USE: kernel
  31 USE: lists
  32 USE: math
  33 USE: namespaces
  34 USE: parser
  35 USE: stdio
  36 USE: strings
  37 USE: presentation
  38 USE: words
  39 USE: unparser
  40 USE: vectors
  41 USE: ansi
  42
  43 SYMBOL: cont-prompt
  44 SYMBOL: listener-prompt
  45 SYMBOL: quit-flag
  46
  47 global [
  48     "..." cont-prompt set
  49     "ok" listener-prompt set
  50 ] bind
  51
  52 : prompt. ( text -- )
  53     "prompt" style write-attr
  54     ! Print the space without a style, to workaround a bug in
  55     ! the GUI listener where the style from the prompt carries
  56     ! over to the input
  57     " " write flush ;
  58
  59 : exit ( -- )
  60     #! Exit the current listener.
  61     quit-flag on ;
  62
  63 : (read-multiline) ( quot depth -- quot ? )
  64     #! Flag indicates EOF.
  65     >r read dup [
  66         (parse) depth r> dup >r <= [
  67             ( we're done ) r> drop t
  68         ] [
  69             ( more input needed ) r> cont-prompt get prompt.
  70             (read-multiline)
  71         ] ifte
  72     ] [
  73         ( EOF ) r> 2drop f
  74     ] ifte ;
  75
  76 : read-multiline ( -- quot ? )
  77     #! Keep parsing until the end is reached. Flag indicates
  78     #! EOF.
  79     f depth (read-multiline) >r reverse r> ;
  80
  81 : listen ( -- )
  82     #! Wait for user input, and execute.
  83     listener-prompt get prompt.
  84     [ read-multiline [ call ] [ exit ] ifte ] try ;
  85
  86 : listener ( -- )
  87     #! Run a listener loop that executes user input.
  88     quit-flag get [ quit-flag off ] [ listen listener ] ifte ;
  89
  90 : kb. 1024 /i unparse write " KB" write ;
  91
  92 : (room.) ( free total -- )
  93     2dup swap - swap ( free used total )
  94     kb. " total " write
  95     kb. " used " write
  96     kb. " free" print ;
  97
  98 : room. ( -- )
  99     room
 100     "Data space: " write (room.)
 101     "Code space: " write (room.) ;
 102
 103 : print-banner ( -- )
 104     "Factor " write version write
 105     " (OS: " write os write
 106     " CPU: " write cpu write
 107     ")" print
 108     "Copyright (C) 2003, 2005 Slava Pestov" print
 109     "Copyright (C) 2004, 2005 Chris Double" print
 110     "Copyright (C) 2004, 2005 Mackenzie Straight" print
 111     "Type ``exit'' to exit, ``help'' for help." print
 112     terpri
 113     room.
 114     terpri ;
 115
 116 : help ( -- )
 117     "SESSION:" print
 118     "\"foo.image\" save-image   -- save heap to a file" print
 119     "room.                    -- show memory usage" print
 120     "heap-stats.              -- memory allocation breakdown" print
 121     "garbage-collection       -- force a GC" print
 122     "exit                     -- exit interpreter" print
 123     terpri
 124     "WORDS:" print
 125     "vocabs.                  -- list vocabularies" print
 126     "\"math\" words.            -- list the math vocabulary" print
 127     "\"str\" apropos.           -- list all words containing str" print
 128     "\\ neg see                -- show word definition" print
 129     "\\ car usages.            -- list all words invoking car" print
 130     terpri
 131     "STACKS:" print
 132     ".s .r .n .c              -- show contents of the 4 stacks" print
 133     "clear                    -- clear datastack" print
 134     terpri
 135     "OBJECTS:" print
 136     "global describe          -- list global variables." print
 137     "\"foo\" get .              -- print a variable value." print
 138     ".                        -- print top of stack." print
 139     terpri
 140     "PROFILER:                [ ... ] call-profile" print
 141     "                         [ ... ] allot-profile" print
 142     "TRACE:                   [ ... ] trace" print
 143     "SINGLE STEP:             [ ... ] walk" print
 144     terpri
 145     "HTTP SERVER:             USE: httpd 8888 httpd" print
 146     "TELNET SERVER:           USE: telnetd 9999 telnetd" print ;
 147
 148 IN: shells
 149
 150 : tty
 151     print-banner listener ;