basis/alien/prettyprint/prettyprint.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel combinators alien alien.enums
   4 alien.strings alien.c-types alien.parser alien.syntax arrays
   5 assocs effects math.parser prettyprint prettyprint.backend
   6 prettyprint.custom prettyprint.sections definitions see
   7 see.private sequences strings words ;
   8 IN: alien.prettyprint
   9
  10 M: alien pprint*
  11     {
  12         { [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] }
  13         { [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
  14         [ \ ALIEN: [ alien-address >hex text ] pprint-prefix ]
  15     } cond ;
  16
  17 M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;
  18
  19 M: c-type-word definer drop \ C-TYPE: f ;
  20 M: c-type-word definition drop f ;
  21 M: c-type-word declarations. drop ;
  22
  23 <PRIVATE
  24 GENERIC: pointer-string ( pointer -- string/f )
  25 M: object pointer-string drop f ;
  26 M: word pointer-string [ record-vocab ] [ name>> ] bi ;
  27 M: pointer pointer-string to>> pointer-string [ CHAR: * suffix ] [ f ] if* ;
  28
  29 GENERIC: c-type-string ( c-type -- string )
  30
  31 M: word c-type-string [ record-vocab ] [ name>> ] bi ;
  32 M: pointer c-type-string dup pointer-string [ ] [ unparse ] ?if ;
  33 M: wrapper c-type-string wrapped>> c-type-string ;
  34 M: array c-type-string
  35     unclip
  36     [ [ unparse "[" "]" surround ] map ]
  37     [ c-type-string ] bi*
  38     prefix concat ;
  39 PRIVATE>
  40
  41 : pprint-c-type ( c-type -- )
  42     [ c-type-string ] keep present-text ;
  43
  44 M: pointer pprint*
  45     <flow \ pointer: pprint-word to>> pprint* block> ;
  46
  47 M: typedef-word definer drop \ TYPEDEF: f ;
  48
  49 M: typedef-word synopsis*
  50     {
  51         [ seeing-word ]
  52         [ definer. ]
  53         [ "c-type" word-prop pprint-c-type ]
  54         [ pprint-word ]
  55     } cleave ;
  56
  57 : pprint-function-arg ( type name -- )
  58     [ pprint-c-type ] [ text ] bi* ;
  59
  60 : pprint-function-args ( types names -- )
  61     zip [ ] [
  62         unclip-last
  63         [ [ first2 "," append pprint-function-arg ] each ] dip
  64         first2 pprint-function-arg
  65     ] if-empty ;
  66
  67 : pprint-library ( library -- )
  68     [ \ LIBRARY: [ text ] pprint-prefix ] when* ;
  69
  70 : pprint-function ( word quot -- )
  71     [ def>> first pprint-c-type ]
  72     swap
  73     [
  74         <block "(" text
  75         [ def>> fourth ] [ stack-effect in>> ] bi
  76         pprint-function-args
  77         ")" text block>
  78     ] tri ; inline
  79
  80 M: alien-function-alias-word definer
  81     drop \ FUNCTION-ALIAS: \ ; ;
  82 M: alien-function-alias-word definition drop f ;
  83 M: alien-function-alias-word synopsis*
  84     {
  85         [ seeing-word ]
  86         [ def>> second pprint-library ]
  87         [ definer. ]
  88         [ pprint-word ]
  89         [ [ def>> third text ] pprint-function ]
  90     } cleave ;
  91
  92 M: alien-function-word definer
  93     drop \ FUNCTION: \ ; ;
  94 M: alien-function-word synopsis*
  95     {
  96         [ seeing-word ]
  97         [ def>> second pprint-library ]
  98         [ definer. ]
  99         [ [ pprint-word ] pprint-function ]
 100     } cleave ;
 101
 102 M: alien-callback-type-word definer
 103     drop \ CALLBACK: \ ; ;
 104 M: alien-callback-type-word definition drop f ;
 105 M: alien-callback-type-word synopsis*
 106     {
 107         [ seeing-word ]
 108         [ "callback-library" word-prop pprint-library ]
 109         [ definer. ]
 110         [ def>> first first pprint-c-type ]
 111         [ pprint-word ]
 112         [
 113             <block "(" text
 114             [ def>> first second ] [ "callback-effect" word-prop in>> ] bi
 115             pprint-function-args
 116             ")" text block>
 117         ]
 118     } cleave ;
 119
 120 M: enum-c-type-word definer
 121     drop \ ENUM: \ ; ;
 122 M: enum-c-type-word synopsis*
 123     {
 124         [ seeing-word ]
 125         [ definer. ]
 126         [ pprint-word ]
 127         [ lookup-c-type base-type>> dup int eq? [ drop ] [ "<" text pprint-word ] if ]
 128     } cleave ;
 129 M: enum-c-type-word definition
 130    lookup-c-type members>> ;