basis/alien/prettyprint/prettyprint.factor

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