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