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 make assocs io sequences
   4 sorting continuations 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 GENERIC# compiler-error. 1 ( error word -- )
  16
  17 <PRIVATE
  18
  19 SYMBOL: compiler-errors
  20
  21 SYMBOL: with-compiler-errors?
  22
  23 : errors-of-type ( type -- assoc )
  24     compiler-errors get-global
  25     swap [ >r nip compiler-error-type r> eq? ] curry
  26     assoc-filter ;
  27
  28 : compiler-errors. ( type -- )
  29     errors-of-type >alist sort-keys
  30     [ swap compiler-error. ] assoc-each ;
  31
  32 : (compiler-report) ( what type word -- )
  33     over errors-of-type assoc-empty? [ 3drop ] [
  34         [
  35             ":" %
  36             %
  37             " - print " %
  38             errors-of-type assoc-size #
  39             " " %
  40             %
  41             "." %
  42         ] "" make print
  43     ] if ;
  44
  45 : compiler-report ( -- )
  46     "semantic errors" +error+ "errors" (compiler-report)
  47     "semantic warnings" +warning+ "warnings" (compiler-report)
  48     "linkage errors" +linkage+ "linkage" (compiler-report) ;
  49
  50 PRIVATE>
  51
  52 : :errors ( -- ) +error+ compiler-errors. ;
  53
  54 : :warnings ( -- ) +warning+ compiler-errors. ;
  55
  56 : :linkage ( -- ) +linkage+ compiler-errors. ;
  57
  58 : compiler-error ( error word -- )
  59     with-compiler-errors? get [
  60         compiler-errors get pick
  61         [ set-at ] [ delete-at drop ] if
  62     ] [ 2drop ] if ;
  63
  64 : with-compiler-errors ( quot -- )
  65     with-compiler-errors? get "quiet" get or [ call ] [
  66         [
  67             with-compiler-errors? on
  68             V{ } clone compiler-errors set-global
  69             [ compiler-report ] [ ] cleanup
  70         ] with-scope
  71     ] if ; inline