core/vocabs/loader/loader.factor

   1 ! Copyright (C) 2007, 2008 Eduardo Cavazos, Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: namespaces make sequences io.files kernel assocs words
   4 vocabs definitions parser continuations io hashtables sorting
   5 source-files arrays combinators strings system math.parser
   6 compiler.errors splitting init accessors ;
   7 IN: vocabs.loader
   8
   9 SYMBOL: vocab-roots
  10
  11 V{
  12     "resource:core"
  13     "resource:basis"
  14     "resource:extra"
  15     "resource:work"
  16 } clone vocab-roots set-global
  17
  18 : vocab-dir ( vocab -- dir )
  19     vocab-name { { CHAR: . CHAR: / } } substitute ;
  20
  21 : vocab-dir+ ( vocab str/f -- path )
  22     >r vocab-name "." split r>
  23     [ >r dup peek r> append suffix ] when*
  24     "/" join ;
  25
  26 : vocab-dir? ( root name -- ? )
  27     over [
  28         ".factor" vocab-dir+ append-path exists?
  29     ] [
  30         2drop f
  31     ] if ;
  32
  33 SYMBOL: root-cache
  34
  35 H{ } clone root-cache set-global
  36
  37 : (find-vocab-root) ( name -- path/f )
  38     vocab-roots get swap [ vocab-dir? ] curry find nip ;
  39
  40 : find-vocab-root ( vocab -- path/f )
  41     vocab-name dup root-cache get at [ ] [ (find-vocab-root) ] ?if ;
  42
  43 : vocab-append-path ( vocab path -- newpath )
  44     swap find-vocab-root dup [ prepend-path ] [ 2drop f ] if ;
  45
  46 : vocab-source-path ( vocab -- path/f )
  47     dup ".factor" vocab-dir+ vocab-append-path ;
  48
  49 : vocab-docs-path ( vocab -- path/f )
  50     dup "-docs.factor" vocab-dir+ vocab-append-path ;
  51
  52 SYMBOL: load-help?
  53
  54 : load-source ( vocab -- vocab )
  55     f over set-vocab-source-loaded?
  56     [ vocab-source-path [ parse-file ] [ [ ] ] if* ] keep
  57     t swap set-vocab-source-loaded?
  58     [ % ] [ call ] if-bootstrapping ;
  59
  60 : load-docs ( vocab -- vocab )
  61     load-help? get [
  62         f over set-vocab-docs-loaded?
  63         [ vocab-docs-path [ ?run-file ] when* ] keep
  64         t swap set-vocab-docs-loaded?
  65     ] [ drop ] if ;
  66
  67 : reload ( name -- )
  68     [
  69         dup vocab [ [ load-source ] [ load-docs ] bi ] [ no-vocab ] ?if
  70     ] with-compiler-errors ;
  71
  72 : require ( vocab -- )
  73     load-vocab drop ;
  74
  75 : run ( vocab -- )
  76     dup load-vocab vocab-main [
  77         execute
  78     ] [
  79         "The " write vocab-name write
  80         " vocabulary does not define an entry point." print
  81         "To define one, refer to \\ MAIN: help" print
  82     ] ?if ;
  83
  84 SYMBOL: blacklist
  85
  86 : add-to-blacklist ( error vocab -- )
  87     vocab-name blacklist get dup [ set-at ] [ 3drop ] if ;
  88
  89 GENERIC: (load-vocab) ( name -- )
  90
  91 M: vocab (load-vocab)
  92     [
  93         dup vocab-source-loaded? [ dup load-source ] unless
  94         dup vocab-docs-loaded? [ dup load-docs ] unless
  95         drop
  96     ] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
  97
  98 M: vocab-link (load-vocab)
  99     vocab-name create-vocab (load-vocab) ;
 100
 101 M: string (load-vocab)
 102     create-vocab (load-vocab) ;
 103
 104 [
 105     [
 106         dup vocab-name blacklist get at* [
 107             rethrow
 108         ] [
 109             drop
 110             dup find-vocab-root [
 111                 [ (load-vocab) ] with-compiler-errors
 112             ] [
 113                 dup vocab [ drop ] [ no-vocab ] if
 114             ] if
 115         ] if
 116     ] with-compiler-errors
 117 ] load-vocab-hook set-global
 118
 119 : vocab-where ( vocab -- loc )
 120     vocab-source-path dup [ 1 2array ] when ;
 121
 122 M: vocab where vocab-where ;
 123
 124 M: vocab-link where vocab-where ;