basis/compiler/tree/builder/builder.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors combinators compiler.tree continuations hints
   4 kernel locals namespaces quotations sequences
   5 stack-checker.backend stack-checker.errors
   6 stack-checker.recursive-state stack-checker.state
   7 stack-checker.visitor vectors words ;
   8 IN: compiler.tree.builder
   9
  10 <PRIVATE
  11
  12 GENERIC: (build-tree) ( quot -- )
  13
  14 M: callable (build-tree) infer-quot-here ;
  15
  16 : check-no-compile ( word -- )
  17     dup "no-compile" word-prop [ do-not-compile ] [ drop ] if ;
  18
  19 : word-body ( word -- quot )
  20     dup inline-recursive? [ 1quotation ] [ specialized-def ] if ;
  21
  22 M: word (build-tree)
  23     [ check-no-compile ]
  24     [ word-body infer-quot-here ]
  25     [ required-stack-effect check-effect ] tri ;
  26
  27 : build-tree-with ( in-stack word/quot -- nodes )
  28     [
  29         <recursive-state> recursive-state set
  30         V{ } clone stack-visitor set
  31         [ [ >vector (meta-d) set ] [ length input-count set ] bi ]
  32         [ (build-tree) ]
  33         bi*
  34     ] with-infer nip ;
  35
  36 PRIVATE>
  37
  38 : build-tree ( word/quot -- nodes )
  39     [ f ] dip build-tree-with ;
  40
  41 :: build-sub-tree ( in-d out-d word/quot -- nodes/f )
  42     [
  43         in-d word/quot build-tree-with unclip-last in-d>> :> in-d'
  44         {
  45             { [ dup not ] [ ] }
  46             { [ dup ends-with-terminate? ] [ out-d [ f swap <#push> ] map append ] }
  47             [ in-d' out-d [ [ length ] bi@ assert= ] [ <#copy> suffix ] 2bi ]
  48         } cond
  49     ] [ inference-error? ] ignore-error/f ;