core/compiler/errors/errors.factor

   1 ! Copyright (C) 2007, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel namespaces assocs prettyprint io sequences
   4 sorting continuations debugger math math.parser ;
   5 IN: compiler.errors
   6
   7 SYMBOL: +error+
   8 SYMBOL: +warning+
   9 SYMBOL: +linkage+
  10
  11 GENERIC: compiler-error-type ( error -- ? )
  12
  13 M: object compiler-error-type drop +error+ ;
  14
  15 <PRIVATE
  16
  17 SYMBOL: compiler-errors
  18
  19 SYMBOL: with-compiler-errors?
  20
  21 : compiler-error. ( error word -- )
  22     nl
  23     "While compiling " write pprint ": " print
  24     nl
  25     print-error ;
  26
  27 : errors-of-type ( type -- assoc )
  28     compiler-errors get-global
  29     swap [ >r nip compiler-error-type r> eq? ] curry
  30     assoc-filter ;
  31
  32 : compiler-errors. ( type -- )
  33     errors-of-type >alist sort-keys
  34     [ swap compiler-error. ] assoc-each ;
  35
  36 : (compiler-report) ( what type word -- )
  37     over errors-of-type assoc-empty? [ 3drop ] [
  38         [
  39             ":" %
  40             %
  41             " - print " %
  42             errors-of-type assoc-size #
  43             " " %
  44             %
  45             "." %
  46         ] "" make print
  47     ] if ;
  48
  49 : compiler-report ( -- )
  50     "semantic errors" +error+ "errors" (compiler-report)
  51     "semantic warnings" +warning+ "warnings" (compiler-report)
  52     "linkage errors" +linkage+ "linkage" (compiler-report) ;
  53
  54 PRIVATE>
  55
  56 : compiler-error ( error word -- )
  57     with-compiler-errors? get [
  58         compiler-errors get pick
  59         [ set-at ] [ delete-at drop ] if
  60     ] [ 2drop ] if ;
  61
  62 : :errors +error+ compiler-errors. ;
  63
  64 : :warnings +warning+ compiler-errors. ;
  65
  66 : :linkage +linkage+ compiler-errors. ;
  67
  68 : with-compiler-errors ( quot -- )
  69     with-compiler-errors? get "quiet" get or [ call ] [
  70         [
  71             with-compiler-errors? on
  72             V{ } clone compiler-errors set-global
  73             [ compiler-report ] [ ] cleanup
  74         ] with-scope
  75     ] if ; inline