log-level?, log-max-level: accept optional name argument

Change `log-error`, etc., to check the name that will be used for
the message, in addition to the log level.

pkgs/racket-pkgs/racket-doc/scribblings/reference/logging.scrbl

@@ -141,12 +141,20 @@ by @racket[": "] before it is sent to receivers.
 
 
 @defproc[(log-level? [logger logger?]
-                     [level (or/c 'fatal 'error 'warning 'info 'debug)])
+                     [level (or/c 'fatal 'error 'warning 'info 'debug)]
+                     [name (or/c symbol? #f) #f])
          boolean?]{
 
 Reports whether any @tech{log receiver} attached to @racket[logger] or
 one of its ancestors is interested in @racket[level] events (or
-potentially lower). Use this function to avoid work generating an
+potentially lower) or @racket[name]. If @racket[name] is @racket[#f],
+the result indicates whether any @tech{log receiver} is interested in
+events at @racket[level] for any name. A true result for
+@racket[(log-level?  logger level name)] implies a true result for
+@racket[(log-level? logger level #f)], but not vice versa if
+@racket[name] is a symbol.
+
+Use this function to avoid work generating an
 event for @racket[log-message] if no receiver is interested in the
 information; this shortcut is built into @racket[log-fatal],
 @racket[log-error], @racket[log-warning], @racket[log-info],
@@ -155,16 +163,21 @@ however, so it should not be used with those forms.
 
 The result of this function can change if a garbage collection
 determines that a log receiver is no longer accessible (and therefore
-that any event information it receives will never become accessible).}
+that any event information it receives will never become accessible).
+
+@history[#:changed "6.1.1.3" @elem{Added the @racket[name] argument.}]}
 
 
-@defproc[(log-max-level [logger logger?])
+@defproc[(log-max-level [logger logger?]
+                        [name (or/c symbol? #f) #f])
          (or/c #f 'fatal 'error 'warning 'info 'debug)]{
 
 Similar to @racket[log-level?], but reports the maximum level of logging for
-which @racket[log-level?] on @racket[logger] returns @racket[#t]. The
+which @racket[log-level?] on @racket[logger] and @racket[name] returns @racket[#t]. The
 result is @racket[#f] if @racket[log-level?] with @racket[logger]
-currently returns @racket[#f] for all levels.}
+currently returns @racket[#f] for all levels.
+
+@history[#:changed "6.1.1.3" @elem{Added the @racket[name] argument.}]}
 
 
 @deftogether[(

pkgs/racket-pkgs/racket-test/tests/racket/logger.rktl

@@ -98,6 +98,27 @@
   (log-test-warning "warning")
   (test "test: warning" (lambda (v) (vector-ref v 1)) (sync r)))
 
+(let ()
+  (define-logger test)
+  (define r (make-log-receiver (current-logger) 'info 'test 'warning))
+  (test #t log-level? test-logger 'warning)
+  (test #t log-level? test-logger 'info)
+  (test #t log-level? test-logger 'info 'test)
+  (test #f log-level? test-logger 'info 'not-test)
+  (test #f log-level? test-logger 'debug 'test)
+  (test 'info log-max-level test-logger)
+  (test 'info log-max-level test-logger 'test)
+  (test 'warning log-max-level test-logger 'not-test)
+  (define r2 (make-log-receiver (current-logger) 'warning 'test 'info))
+  (test #t log-level? test-logger 'info 'test)
+  (test #t log-level? test-logger 'info 'not-test)
+  (test #f log-level? test-logger 'debug 'test)
+  (test 'info log-max-level test-logger)
+  (test 'info log-max-level test-logger 'test)
+  (test 'info log-max-level test-logger 'not-test)
+  (test #f sync/timeout 0 r)
+  (test #f sync/timeout 0 r2))
+
 ; ----------------------------------------
 
 (let ()

racket/collects/racket/private/logger.rkt

@@ -6,25 +6,26 @@
   (#%provide log-fatal log-error log-warning log-info log-debug
              define-logger)
 
-  (define-for-syntax (make-define-log mode X-logger-stx)
+  (define-for-syntax (make-define-log mode X-logger-stx name)
     (lambda (stx)
       (with-syntax ([X-logger X-logger-stx]
-                    [mode mode])
+                    [mode mode]
+                    [name name])
         (syntax-case stx ()
           [(_ str-expr) 
            #'(let ([l X-logger])
-               (when (log-level? l 'mode)
+               (when (log-level? l 'mode name)
                  (log-message l 'mode str-expr (current-continuation-marks))))]
           [(_ str-expr arg ...)
            #'(let ([l X-logger])
-               (when (log-level? l 'mode)
+               (when (log-level? l 'mode name)
                  (log-message l 'mode (format str-expr arg ...) (current-continuation-marks))))]))))
 
-  (define-syntax log-fatal (make-define-log 'fatal #'(current-logger)))
+  (define-syntax log-fatal (make-define-log 'fatal #'(current-logger) #'(logger-name l)))
-  (define-syntax log-error (make-define-log 'error #'(current-logger)))
+  (define-syntax log-error (make-define-log 'error #'(current-logger) #'(logger-name l)))
-  (define-syntax log-warning (make-define-log 'warning #'(current-logger)))
+  (define-syntax log-warning (make-define-log 'warning #'(current-logger) #'(logger-name l)))
-  (define-syntax log-info (make-define-log 'info #'(current-logger)))
+  (define-syntax log-info (make-define-log 'info #'(current-logger) #'(logger-name l)))
-  (define-syntax log-debug (make-define-log 'debug #'(current-logger)))
+  (define-syntax log-debug (make-define-log 'debug #'(current-logger) #'(logger-name l)))
 
   (define (check-logger who)
     (lambda (v)
@@ -50,8 +51,8 @@
                        [X X])
            #'(begin
                (define X-logger (make-logger 'X (current-logger)))
-               (define-syntax log-X-fatal (make-define-log 'fatal #'X-logger))
+               (define-syntax log-X-fatal (make-define-log 'fatal #'X-logger #''X))
-               (define-syntax log-X-error (make-define-log 'error #'X-logger))
+               (define-syntax log-X-error (make-define-log 'error #'X-logger #''X))
-               (define-syntax log-X-warning (make-define-log 'warning #'X-logger))
+               (define-syntax log-X-warning (make-define-log 'warning #'X-logger #''X))
-               (define-syntax log-X-info (make-define-log 'info #'X-logger))
+               (define-syntax log-X-info (make-define-log 'info #'X-logger #''X))
-               (define-syntax log-X-debug (make-define-log 'debug #'X-logger)))))])))
+               (define-syntax log-X-debug (make-define-log 'debug #'X-logger #''X)))))])))

racket/src/racket/src/error.c

@@ -133,7 +133,7 @@ static int log_reader_get(Scheme_Object *ch, Scheme_Schedule_Info *sinfo);
 static Scheme_Object *do_raise(Scheme_Object *arg, int need_debug, int barrier);
 static Scheme_Object *nested_exn_handler(void *old_exn, int argc, Scheme_Object *argv[]);
 
-static void update_want_level(Scheme_Logger *logger);
+static void update_want_level(Scheme_Logger *logger, Scheme_Object *name);
 
 static Scheme_Object *check_arity_property_value_ok(int argc, Scheme_Object *argv[]);
 
@@ -725,8 +725,8 @@ void scheme_init_error(Scheme_Env *env)
 
   /* logging */
   GLOBAL_NONCM_PRIM("exit",              scheme_do_exit,  0, 1, env);
-  GLOBAL_NONCM_PRIM("log-level?",        log_level_p,     2, 2, env);
+  GLOBAL_NONCM_PRIM("log-level?",        log_level_p,     2, 3, env);
-  GLOBAL_NONCM_PRIM("log-max-level",     log_max_level,   1, 1, env);
+  GLOBAL_NONCM_PRIM("log-max-level",     log_max_level,   1, 2, env);
   GLOBAL_NONCM_PRIM("make-logger",       make_logger,     0, 2, env);
   GLOBAL_NONCM_PRIM("make-log-receiver", make_log_reader, 2, -1, env);
 
@@ -1081,7 +1081,7 @@ int scheme_log_level_p(Scheme_Logger *logger, int level)
   }
 
   if (logger->local_timestamp < *logger->timestamp)
-    update_want_level(logger);
+    update_want_level(logger, NULL);
 
   return (logger->want_level >= level);
 }
@@ -3431,10 +3431,13 @@ static int extract_spec_level(Scheme_Object *level_spec, Scheme_Object *name)
   }
 }
 
-static int extract_max_spec_level(Scheme_Object *level_spec)
+static int extract_max_spec_level(Scheme_Object *level_spec, Scheme_Object *name)
 {
   int mx = 0, v;
 
+  if (name)
+    return extract_spec_level(level_spec, name);
+
   if (level_spec)  {
     while (1) {
       if (SCHEME_INTP(level_spec)) {
@@ -3452,11 +3455,11 @@ static int extract_max_spec_level(Scheme_Object *level_spec)
   return mx;
 }
 
-void update_want_level(Scheme_Logger *logger)
+void update_want_level(Scheme_Logger *logger, Scheme_Object *name)
 {
   Scheme_Log_Reader *lr;
   Scheme_Object *stack = NULL, *queue, *b, *prev;
-  Scheme_Logger *parent = logger;
+  Scheme_Logger *parent = logger, *orig_logger = logger;
   int want_level, level;
 
   while (parent) {
@@ -3475,7 +3478,7 @@ void update_want_level(Scheme_Logger *logger)
       b = SCHEME_CAR(b);
       lr = (Scheme_Log_Reader *)SCHEME_BOX_VAL(b);
       if (lr) {
-        level = extract_max_spec_level(lr->level);
+        level = extract_max_spec_level(lr->level, name);
         if (level > want_level)
           want_level = level;
         prev = queue;
@@ -3488,18 +3491,80 @@ void update_want_level(Scheme_Logger *logger)
       queue = SCHEME_CDR(queue);
     }
 
-    level = extract_max_spec_level(parent->syslog_level);
+    level = extract_max_spec_level(parent->syslog_level, name);
     if (level > want_level)
       want_level = level;
-    level = extract_max_spec_level(parent->stderr_level);
+    level = extract_max_spec_level(parent->stderr_level, name);
     if (level > want_level)
       want_level = level;    
 
     stack = SCHEME_CDR(stack);
   }
 
+  if (!name) {
     logger->want_level = want_level;
     logger->local_timestamp = *logger->timestamp;
+  } else {
+#   define WANT_NAME_LEVEL_CACHE_SIZE 8
+    int i;
+
+    logger = orig_logger;
+
+    b = logger->want_name_level_cache;
+    if (!b) {
+      b = scheme_make_vector(3 * WANT_NAME_LEVEL_CACHE_SIZE, scheme_make_integer(-1));
+      logger->want_name_level_cache = b;
+    }
+
+    /* find a slot already matching this name? */
+    for (i = SCHEME_VEC_SIZE(b); (i -= 3) >= 0; ) {
+      if (SAME_OBJ(name, SCHEME_VEC_ELS(b)[i]))
+        break;
+    }
+    if (i == 0) abort();
+    if (i < 0) {
+      /* find an out-of-date slot? */
+      for (i = SCHEME_VEC_SIZE(b); (i -= 3) >= 0; ) {
+        if (SCHEME_INT_VAL(SCHEME_VEC_ELS(b)[i+1]) < *logger->timestamp)
+          break;
+      }
+      if (i < 0) {
+        /* rotate cache */
+        i = 3 * (WANT_NAME_LEVEL_CACHE_SIZE - 1);
+        memmove(&(SCHEME_VEC_ELS(b)[0]), 
+                &(SCHEME_VEC_ELS(b)[3]), 
+                i * sizeof(Scheme_Object *));
+      }
+    }
+
+    SCHEME_VEC_ELS(b)[i] = name;
+    SCHEME_VEC_ELS(b)[i+1] = scheme_make_integer(*logger->timestamp);
+    SCHEME_VEC_ELS(b)[i+2] = scheme_make_integer(want_level);
+  }
+}
+
+static int get_want_level(Scheme_Logger *logger, Scheme_Object *name)
+{
+  if (name && SCHEME_TRUEP(name)) {
+    while (1) {
+      if (logger->want_name_level_cache) {
+        int i;
+        for (i = SCHEME_VEC_SIZE(logger->want_name_level_cache); (i -= 3) >= 0; ) {
+          if (SAME_OBJ(name, SCHEME_VEC_ELS(logger->want_name_level_cache)[i])) {
+            if (SCHEME_INT_VAL(SCHEME_VEC_ELS(logger->want_name_level_cache)[i+1]) == *logger->timestamp) {
+              return SCHEME_INT_VAL(SCHEME_VEC_ELS(logger->want_name_level_cache)[i+2]);
+            }
+          }
+        }
+      }
+      update_want_level(logger, name);
+    }
+  } else {
+    if (logger->local_timestamp < *logger->timestamp)
+      update_want_level(logger, NULL);
+
+    return logger->want_level;
+  }
 }
 
 #ifdef USE_WINDOWS_EVENT_LOG
@@ -3572,7 +3637,6 @@ void scheme_log_name_pfx_message(Scheme_Logger *logger, int level, Scheme_Object
      configuration of scheme_log_abort(). */
   Scheme_Object *queue, *q, *msg = NULL, *b;
   Scheme_Log_Reader *lr;
-  Scheme_Logger *lo;
 
   if (!logger) {
     Scheme_Config *config;
@@ -3581,7 +3645,7 @@ void scheme_log_name_pfx_message(Scheme_Logger *logger, int level, Scheme_Object
   }
 
   if (logger->local_timestamp < *logger->timestamp)
-    update_want_level(logger);
+    update_want_level(logger, NULL);
 
   if (logger->want_level < level)
     return;
@@ -3874,7 +3938,8 @@ static Scheme_Object *
 log_level_p(int argc, Scheme_Object *argv[])
 {
   Scheme_Logger *logger;
-  int level;
+  Scheme_Object *name = scheme_false;
+  int level, want_level;
 
   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_logger_type))
     scheme_wrong_contract("log-level?", "logger?", 0, argc, argv);
@@ -3882,25 +3947,34 @@ log_level_p(int argc, Scheme_Object *argv[])
 
   level = extract_level("log-level?", 0, 1, argc, argv);
 
-  if (logger->local_timestamp < *logger->timestamp)
+  if (argc > 2) {
-    update_want_level(logger);
+    if (!SCHEME_FALSEP(argv[2]) && !SCHEME_SYMBOLP(argv[2]))
+      scheme_wrong_contract("log-level?", "(or/c f? #symbol)", 2, argc, argv);
+    name = argv[2];
+  }
 
-  return ((logger->want_level >= level) ? scheme_true : scheme_false);
+  want_level = get_want_level(logger, name);
+
+  return ((want_level >= level) ? scheme_true : scheme_false);
 }
 
 static Scheme_Object *
 log_max_level(int argc, Scheme_Object *argv[])
 {
   Scheme_Logger *logger;
+  Scheme_Object *name = scheme_false;
 
   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_logger_type))
     scheme_wrong_contract("log-max-level", "logger?", 0, argc, argv);
   logger = (Scheme_Logger *)argv[0];
 
-  if (logger->local_timestamp < *logger->timestamp)
+  if (argc > 1) {
-    update_want_level(logger);
+    if (!SCHEME_FALSEP(argv[1]) && !SCHEME_SYMBOLP(argv[1]))
+      scheme_wrong_contract("log-max-level", "(or/c f? #symbol)", 1, argc, argv);
+    name = argv[1];
+  }
   
-  switch (logger->want_level) {
+  switch (get_want_level(logger, name)) {
   case 0:
     return scheme_false;
   case SCHEME_LOG_FATAL:

racket/src/racket/src/mzmark_type.inc

@@ -3004,6 +3004,7 @@ static int mark_logger_MARK(void *p, struct NewGC *gc) {
   Scheme_Logger *l = (Scheme_Logger *)p;
   gcMARK2(l->name, gc);
   gcMARK2(l->parent, gc);
+  gcMARK2(l->want_name_level_cache, gc);
   gcMARK2(l->timestamp, gc);
   gcMARK2(l->syslog_level, gc);
   gcMARK2(l->stderr_level, gc);
@@ -3016,6 +3017,7 @@ static int mark_logger_FIXUP(void *p, struct NewGC *gc) {
   Scheme_Logger *l = (Scheme_Logger *)p;
   gcFIXUP2(l->name, gc);
   gcFIXUP2(l->parent, gc);
+  gcFIXUP2(l->want_name_level_cache, gc);
   gcFIXUP2(l->timestamp, gc);
   gcFIXUP2(l->syslog_level, gc);
   gcFIXUP2(l->stderr_level, gc);

racket/src/racket/src/mzmarksrc.c

@@ -1207,6 +1207,7 @@ mark_logger {
   Scheme_Logger *l = (Scheme_Logger *)p;
   gcMARK2(l->name, gc);
   gcMARK2(l->parent, gc);
+  gcMARK2(l->want_name_level_cache, gc);
   gcMARK2(l->timestamp, gc);
   gcMARK2(l->syslog_level, gc);
   gcMARK2(l->stderr_level, gc);

racket/src/racket/src/schpriv.h

@@ -3693,6 +3693,7 @@ struct Scheme_Logger {
   Scheme_Object *name;
   Scheme_Logger *parent;
   int want_level;
+  Scheme_Object *want_name_level_cache; /* vector */
   intptr_t *timestamp, local_timestamp; /* determines when want_level is up-to-date */
   Scheme_Object *syslog_level; /* (list* <level-int> <name-sym> ... <level-int>) */
   Scheme_Object *stderr_level;