Merge remote-tracking branch 'origin/stable-2.0'
authorAndy Wingo <wingo@pobox.com>
Fri, 11 May 2012 12:31:17 +0000 (14:31 +0200)
committerAndy Wingo <wingo@pobox.com>
Fri, 11 May 2012 12:31:17 +0000 (14:31 +0200)
1  2 
libguile/frames.c
libguile/stacks.c
module/ice-9/boot-9.scm

diff --combined libguile/frames.c
@@@ -52,12 -52,12 +52,12 @@@ scm_c_make_frame (SCM stack_holder, SC
  void
  scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate)
  {
 -  scm_puts ("#<frame ", port);
 +  scm_puts_unlocked ("#<frame ", port);
    scm_uintprint (SCM_UNPACK (frame), 16, port);
 -  scm_putc (' ', port);
 +  scm_putc_unlocked (' ', port);
    scm_write (scm_frame_procedure (frame), port);
    /* don't write args, they can get us into trouble. */
 -  scm_puts (">", port);
 +  scm_puts_unlocked (">", port);
  }
  
  \f
@@@ -104,11 -104,18 +104,18 @@@ SCM_DEFINE (scm_frame_source, "frame-so
            "")
  #define FUNC_NAME s_scm_frame_source
  {
+   SCM proc;
    SCM_VALIDATE_VM_FRAME (1, frame);
  
-   return scm_program_source (scm_frame_procedure (frame),
-                              scm_frame_instruction_pointer (frame),
-                              SCM_UNDEFINED);
+   proc = scm_frame_procedure (frame);
+   if (SCM_PROGRAM_P (proc))
+     return scm_program_source (scm_frame_procedure (frame),
+                                scm_frame_instruction_pointer (frame),
+                                SCM_UNDEFINED);
+   return SCM_BOOL_F;
  }
  #undef FUNC_NAME
  
@@@ -296,6 -303,7 +303,7 @@@ SCM_DEFINE (scm_frame_previous, "frame-
  #define FUNC_NAME s_scm_frame_previous
  {
    SCM *this_fp, *new_fp, *new_sp;
+   SCM proc;
  
    SCM_VALIDATE_VM_FRAME (1, frame);
  
    this_fp = SCM_VM_FRAME_FP (frame);
    new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
    if (new_fp) 
-     { new_fp = RELOC (frame, new_fp);
+     {
+       new_fp = RELOC (frame, new_fp);
        new_sp = SCM_FRAME_LOWER_ADDRESS (this_fp) - 1;
        frame = scm_c_make_frame (SCM_VM_FRAME_STACK_HOLDER (frame),
                                  new_fp, new_sp,
                                  SCM_FRAME_RETURN_ADDRESS (this_fp),
                                  SCM_VM_FRAME_OFFSET (frame));
-       if (SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
+       proc = scm_frame_procedure (frame);
+       if (SCM_PROGRAM_P (proc) && SCM_PROGRAM_IS_BOOT (proc))
          goto again;
        else
          return frame;
diff --combined libguile/stacks.c
@@@ -95,21 -95,23 +95,21 @@@ stack_depth (SCM frame
   * encountered.
   */
  
 -static SCM
 +static SCM*
  find_prompt (SCM key)
  {
 -  SCM winds;
 -  for (winds = scm_i_dynwinds (); scm_is_pair (winds); winds = scm_cdr (winds))
 -    {
 -      SCM elt = scm_car (winds);
 -      if (SCM_PROMPT_P (elt) && scm_is_eq (SCM_PROMPT_TAG (elt), key))
 -        return elt;
 -    }
 -  scm_misc_error ("make-stack", "Prompt tag not found while narrowing stack",
 -                  scm_list_1 (key));
 -  return SCM_BOOL_F; /* not reached */
 +  SCM *fp;
 +
 +  if (!scm_dynstack_find_prompt (&SCM_I_CURRENT_THREAD->dynstack, key,
 +                                 NULL, &fp, NULL, NULL, NULL))
 +    scm_misc_error ("make-stack", "Prompt tag not found while narrowing stack",
 +                    scm_list_1 (key));
 +
 +  return fp;
  }
  
  static void
 -narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
 +narrow_stack (SCM stack, SCM inner_cut, SCM outer_cut)
  {
    unsigned long int len;
    SCM frame;
    frame = SCM_STACK_FRAME (stack);
  
    /* Cut inner part. */
 -  if (scm_is_true (scm_procedure_p (inner_key)))
 +  if (scm_is_true (scm_procedure_p (inner_cut)))
      {
        /* Cut until the given procedure is seen. */
 -      for (; inner && len ; --inner)
 +      for (; len ;)
          {
            SCM proc = scm_frame_procedure (frame);
            len--;
            frame = scm_frame_previous (frame);
 -          if (scm_is_eq (proc, inner_key))
 +          if (scm_is_eq (proc, inner_cut))
              break;
          }
      }
 -  else if (scm_is_symbol (inner_key))
 -    {
 -      /* Cut until the given prompt tag is seen. FIXME, assumes prompt tags are
 -         symbols. */
 -      SCM prompt = find_prompt (inner_key);
 -      for (; len; len--, frame = scm_frame_previous (frame))
 -        if (SCM_PROMPT_REGISTERS (prompt)->fp
 -            == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
 -          break;
 -    }
 -  else
 +  else if (scm_is_integer (inner_cut))
      {
        /* Cut specified number of frames. */
 +      long inner = scm_to_int (inner_cut);
 +      
        for (; inner && len; --inner)
          {
            len--;
            frame = scm_frame_previous (frame);
          }
      }
 +  else
 +    {
 +      /* Cut until the given prompt tag is seen. */
 +      SCM *fp = find_prompt (inner_cut);
 +      for (; len; len--, frame = scm_frame_previous (frame))
 +        if (fp == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
 +          break;
 +    }
  
    SCM_SET_STACK_LENGTH (stack, len);
    SCM_SET_STACK_FRAME (stack, frame);
  
    /* Cut outer part. */
 -  if (scm_is_true (scm_procedure_p (outer_key)))
 +  if (scm_is_true (scm_procedure_p (outer_cut)))
      {
        /* Cut until the given procedure is seen. */
 -      for (; outer && len ; --outer)
 +      for (; len ;)
          {
            frame = scm_stack_ref (stack, scm_from_long (len - 1));
            len--;
 -          if (scm_is_eq (scm_frame_procedure (frame), outer_key))
 +          if (scm_is_eq (scm_frame_procedure (frame), outer_cut))
              break;
          }
      }
 -  else if (scm_is_symbol (outer_key))
 +  else if (scm_is_integer (outer_cut))
 +    {
 +      /* Cut specified number of frames. */
 +      long outer = scm_to_int (outer_cut);
 +      
 +      if (outer < len)
 +        len -= outer;
 +      else
 +        len = 0;
 +    }
 +  else
      {
 -      /* Cut until the given prompt tag is seen. FIXME, assumes prompt tags are
 -         symbols. */
 -      SCM prompt = find_prompt (outer_key);
 +      /* Cut until the given prompt tag is seen. */
 +      SCM *fp = find_prompt (outer_cut);
        while (len)
          {
            frame = scm_stack_ref (stack, scm_from_long (len - 1));
            len--;
 -          if (SCM_PROMPT_REGISTERS (prompt)->fp
 -              == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
 +          if (fp == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
              break;
          }
      }
 -  else
 -    {
 -      /* Cut specified number of frames. */
 -      if (outer < len)
 -        len -= outer;
 -      else
 -        len = 0;
 -    }
  
    SCM_SET_STACK_LENGTH (stack, len);
  }
@@@ -255,7 -257,7 +255,7 @@@ SCM_DEFINE (scm_make_stack, "make-stack
        SCM cont;
        struct scm_vm_cont *c;
  
 -      cont = scm_i_vm_capture_continuation (scm_the_vm ());
 +      cont = scm_i_capture_current_stack ();
        c = SCM_VM_CONT_DATA (cont);
  
        frame = scm_c_make_frame (cont, c->fp + c->reloc,
  
    /* FIXME: is this even possible? */
    if (scm_is_true (frame)
+       && SCM_PROGRAM_P (scm_frame_procedure (frame))
        && SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
      frame = scm_frame_previous (frame);
    
        }
        
        narrow_stack (stack,
 -                  scm_is_integer (inner_cut) ? scm_to_int (inner_cut) : n,
 -                  scm_is_integer (inner_cut) ? SCM_BOOL_T : inner_cut,
 -                  scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n,
 -                  scm_is_integer (outer_cut) ? SCM_BOOL_T : outer_cut);
 +                    inner_cut,
 +                    outer_cut);
  
        n = SCM_STACK_LENGTH (stack);
      }
diff --combined module/ice-9/boot-9.scm
  
  (define make-prompt-tag
    (lambda* (#:optional (stem "prompt"))
 -    (gensym stem)))
 +    ;; The only property that prompt tags need have is uniqueness in the
 +    ;; sense of eq?.  A one-element list will serve nicely.
 +    (list stem)))
  
  (define default-prompt-tag
 -  ;; not sure if we should expose this to the user as a fluid
 +  ;; Redefined later to be a parameter.
    (let ((%default-prompt-tag (make-prompt-tag)))
      (lambda ()
        %default-prompt-tag)))
@@@ -188,105 -186,10 +188,105 @@@ If there is no handler at all, Guile pr
  
  \f
  
 -;;; {R4RS compliance}
 +;;; {Language primitives}
 +;;;
 +
 +;; These are are the procedural wrappers around the primitives of
 +;; Guile's language: @apply, @call-with-current-continuation, etc.
 +;;
 +;; Usually, a call to a primitive is compiled specially.  The compiler
 +;; knows about all these kinds of expressions.  But the primitives may
 +;; be referenced not only as operators, but as values as well.  These
 +;; stub procedures are the "values" of apply, dynamic-wind, and other
 +;; such primitives.
 +;;
 +(define (apply fun . args)
 +  (@apply fun (apply:nconc2last args)))
 +(define (call-with-current-continuation proc)
 +  (@call-with-current-continuation proc))
 +(define (call-with-values producer consumer)
 +  (@call-with-values producer consumer))
 +(define (dynamic-wind in thunk out)
 +  "All three arguments must be 0-argument procedures.
 +Guard @var{in} is called, then @var{thunk}, then
 +guard @var{out}.
 +
 +If, any time during the execution of @var{thunk}, the
 +continuation of the @code{dynamic_wind} expression is escaped
 +non-locally, @var{out} is called.  If the continuation of
 +the dynamic-wind is re-entered, @var{in} is called.  Thus
 +@var{in} and @var{out} may be called any number of
 +times.
 +@lisp
 + (define x 'normal-binding)
 +@result{} x
 + (define a-cont
 +   (call-with-current-continuation
 +     (lambda (escape)
 +       (let ((old-x x))
 +         (dynamic-wind
 +           ;; in-guard:
 +           ;;
 +           (lambda () (set! x 'special-binding))
 +
 +           ;; thunk
 +           ;;
 +           (lambda () (display x) (newline)
 +                   (call-with-current-continuation escape)
 +                   (display x) (newline)
 +                   x)
 +
 +           ;; out-guard:
 +           ;;
 +           (lambda () (set! x old-x)))))))
 +
 +;; Prints:
 +special-binding
 +;; Evaluates to:
 +@result{} a-cont
 +x
 +@result{} normal-binding
 + (a-cont #f)
 +;; Prints:
 +special-binding
 +;; Evaluates to:
 +@result{} a-cont  ;; the value of the (define a-cont...)
 +x
 +@result{} normal-binding
 +a-cont
 +@result{} special-binding
 +@end lisp"
 +  (@dynamic-wind in (thunk) out))
 +
 +\f
 +
 +;;; {Low-Level Port Code}
  ;;;
  
 -(primitive-load-path "ice-9/r4rs")
 +;; These are used to request the proper mode to open files in.
 +;;
 +(define OPEN_READ "r")
 +(define OPEN_WRITE "w")
 +(define OPEN_BOTH "r+")
 +
 +(define *null-device* "/dev/null")
 +
 +(define (open-input-file str)
 +  "Takes a string naming an existing file and returns an input port
 +capable of delivering characters from the file.  If the file
 +cannot be opened, an error is signalled."
 +  (open-file str OPEN_READ))
 +
 +(define (open-output-file str)
 +  "Takes a string naming an output file to be created and returns an
 +output port capable of writing characters to a new file by that
 +name.  If the file cannot be opened, an error is signalled.  If a
 +file with the given name already exists, the effect is unspecified."
 +  (open-file str OPEN_WRITE))
 +
 +(define (open-io-file str) 
 +  "Open file with name STR for both input and output."
 +  (open-file str OPEN_BOTH))
  
  \f
  
  (define current-warning-port current-error-port)
  
  (define (warn . stuff)
 -  (with-output-to-port (current-warning-port)
 -    (lambda ()
 -      (newline)
 -      (display ";;; WARNING ")
 -      (display stuff)
 -      (newline)
 -      (car (last-pair stuff)))))
 +  (newline (current-warning-port))
 +  (display ";;; WARNING " (current-warning-port))
 +  (display stuff (current-warning-port))
 +  (newline (current-warning-port))
 +  (car (last-pair stuff)))
  
  \f
  
@@@ -875,7 -780,8 +875,8 @@@ information is unavailable.
                (let ((proc (frame-procedure frame)))
                  (print-location frame port)
                  (format port "In procedure ~a:\n"
-                         (or (procedure-name proc) proc))))
+                         (or (false-if-exception (procedure-name proc))
+                             proc))))
  
            (print-location frame port)
            (catch #t
@@@ -1057,11 -963,15 +1058,11 @@@ VALUE.
  ;; properties within the object itself.
  
  (define (make-object-property)
 -  (define-syntax-rule (with-mutex lock exp)
 -    (dynamic-wind (lambda () (lock-mutex lock))
 -                  (lambda () exp)
 -                  (lambda () (unlock-mutex lock))))
 -  (let ((prop (make-weak-key-hash-table))
 -        (lock (make-mutex)))
 +  ;; Weak tables are thread-safe.
 +  (let ((prop (make-weak-key-hash-table)))
      (make-procedure-with-setter
 -     (lambda (obj) (with-mutex lock (hashq-ref prop obj)))
 -     (lambda (obj val) (with-mutex lock (hashq-set! prop obj val))))))
 +     (lambda (obj) (hashq-ref prop obj))
 +     (lambda (obj val) (hashq-set! prop obj val)))))
  
  
  \f
  
  ;; 0: type-name, 1: fields, 2: constructor
  (define record-type-vtable
 -  ;; FIXME: This should just call make-vtable, not make-vtable-vtable; but for
 -  ;; that we need to expose the bare vtable-vtable to Scheme.
 -  (make-vtable-vtable "prprpw" 0
 -                      (lambda (s p)
 -                        (cond ((eq? s record-type-vtable)
 -                               (display "#<record-type-vtable>" p))
 -                              (else
 -                               (display "#<record-type " p)
 -                               (display (record-type-name s) p)
 -                               (display ">" p))))))
 +  (let ((s (make-vtable (string-append standard-vtable-fields "prprpw")
 +                        (lambda (s p)
 +                          (display "#<record-type " p)
 +                          (display (record-type-name s) p)
 +                          (display ">" p)))))
 +    (set-struct-vtable-name! s 'record-type)
 +    s))
  
  (define (record-type? obj)
    (and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
  
  (provide 'record)
  
 +
 +\f
 +;;; {Parameters}
 +;;;
 +
 +(define <parameter>
 +  ;; Three fields: the procedure itself, the fluid, and the converter.
 +  (make-struct <applicable-struct-vtable> 0 'pwprpr))
 +(set-struct-vtable-name! <parameter> '<parameter>)
 +
 +(define* (make-parameter init #:optional (conv (lambda (x) x)))
 +  (let ((fluid (make-fluid (conv init))))
 +    (make-struct <parameter> 0
 +                 (case-lambda
 +                   (() (fluid-ref fluid))
 +                   ((x) (let ((prev (fluid-ref fluid)))
 +                          (fluid-set! fluid (conv x))
 +                          prev)))
 +                 fluid conv)))
 +
 +(define (parameter? x)
 +  (and (struct? x) (eq? (struct-vtable x) <parameter>)))
 +
 +(define (parameter-fluid p)
 +  (if (parameter? p)
 +      (struct-ref p 1)
 +      (scm-error 'wrong-type-arg "parameter-fluid"
 +                 "Not a parameter: ~S" (list p) #f)))
 +
 +(define (parameter-converter p)
 +  (if (parameter? p)
 +      (struct-ref p 2)
 +      (scm-error 'wrong-type-arg "parameter-fluid"
 +                 "Not a parameter: ~S" (list p) #f)))
 +
 +(define-syntax parameterize
 +  (lambda (x)
 +    (syntax-case x ()
 +      ((_ ((param value) ...) body body* ...)
 +       (with-syntax (((p ...) (generate-temporaries #'(param ...))))
 +         #'(let ((p param) ...)
 +             (if (not (parameter? p))
 +                        (scm-error 'wrong-type-arg "parameterize"
 +                                   "Not a parameter: ~S" (list p) #f))
 +             ...
 +             (with-fluids (((struct-ref p 1) ((struct-ref p 2) value))
 +                           ...)
 +               body body* ...)))))))
 +
 +\f
 +
 +;;; Once parameters have booted, define the default prompt tag as being
 +;;; a parameter.
 +;;;
 +
 +(set! default-prompt-tag (make-parameter (default-prompt-tag)))
 +
 +\f
 +
 +;;; Current ports as parameters.
 +;;;
 +
 +(let ((fluid->parameter
 +       (lambda (fluid conv)
 +         (make-struct <parameter> 0
 +                      (case-lambda
 +                        (() (fluid-ref fluid))
 +                        ((x) (let ((prev (fluid-ref fluid)))
 +                               (fluid-set! fluid (conv x))
 +                               prev)))
 +                      fluid conv))))
 +  (define-syntax-rule (port-parameterize! binding fluid predicate msg)
 +    (begin
 +      (set! binding (fluid->parameter (module-ref (current-module) 'fluid)
 +                                      (lambda (x)
 +                                        (if (predicate x) x
 +                                            (error msg x)))))
 +      (hashq-remove! (%get-pre-modules-obarray) 'fluid)))
 +  
 +  (port-parameterize! current-input-port %current-input-port-fluid
 +                      input-port? "expected an input port")
 +  (port-parameterize! current-output-port %current-output-port-fluid
 +                      output-port? "expected an output port")
 +  (port-parameterize! current-error-port %current-error-port-fluid
 +                      output-port? "expected an output port"))
 +
 +\f
 +
 +;;; {Warnings}
 +;;;
 +
 +(define current-warning-port
 +  (make-parameter (current-error-port)
 +                  (lambda (x)
 +                    (if (output-port? x)
 +                        x
 +                        (error "expected an output port" x)))))
 +
 +\f
 +
 +;;; {High-Level Port Routines}
 +;;;
 +
 +(define (call-with-input-file str proc)
 +  "PROC should be a procedure of one argument, and STR should be a
 +string naming a file.  The file must already exist. These procedures
 +call PROC with one argument: the port obtained by opening the named file
 +for input or output.  If the file cannot be opened, an error is
 +signalled.  If the procedure returns, then the port is closed
 +automatically and the values yielded by the procedure are returned.  If
 +the procedure does not return, then the port will not be closed
 +automatically unless it is possible to prove that the port will never
 +again be used for a read or write operation."
 +  (let ((p (open-input-file str)))
 +    (call-with-values
 +      (lambda () (proc p))
 +      (lambda vals
 +        (close-input-port p)
 +        (apply values vals)))))
 +
 +(define (call-with-output-file str proc)
 +  "PROC should be a procedure of one argument, and STR should be a
 +string naming a file.  The behaviour is unspecified if the file 
 +already exists. These procedures call PROC
 +with one argument: the port obtained by opening the named file for
 +input or output.  If the file cannot be opened, an error is
 +signalled.  If the procedure returns, then the port is closed
 +automatically and the values yielded by the procedure are returned.
 +If the procedure does not return, then the port will not be closed
 +automatically unless it is possible to prove that the port will
 +never again be used for a read or write operation."
 +  (let ((p (open-output-file str)))
 +    (call-with-values
 +      (lambda () (proc p))
 +      (lambda vals
 +        (close-output-port p)
 +        (apply values vals)))))
 +
 +(define (with-input-from-port port thunk)
 +  (parameterize ((current-input-port port))
 +    (thunk)))
 +
 +(define (with-output-to-port port thunk)
 +  (parameterize ((current-output-port port))
 +    (thunk)))
 +
 +(define (with-error-to-port port thunk)
 +  (parameterize ((current-error-port port))
 +    (thunk)))
 +
 +(define (with-input-from-file file thunk)
 +  "THUNK must be a procedure of no arguments, and FILE must be a
 +string naming a file.  The file must already exist. The file is opened for
 +input, an input port connected to it is made
 +the default value returned by `current-input-port', 
 +and the THUNK is called with no arguments.
 +When the THUNK returns, the port is closed and the previous
 +default is restored.  Returns the values yielded by THUNK.  If an
 +escape procedure is used to escape from the continuation of these
 +procedures, their behavior is implementation dependent."
 +  (call-with-input-file file
 +   (lambda (p) (with-input-from-port p thunk))))
 +
 +(define (with-output-to-file file thunk)
 +  "THUNK must be a procedure of no arguments, and FILE must be a
 +string naming a file.  The effect is unspecified if the file already exists. 
 +The file is opened for output, an output port connected to it is made
 +the default value returned by `current-output-port', 
 +and the THUNK is called with no arguments.
 +When the THUNK returns, the port is closed and the previous
 +default is restored.  Returns the values yielded by THUNK.  If an
 +escape procedure is used to escape from the continuation of these
 +procedures, their behavior is implementation dependent."
 +  (call-with-output-file file
 +   (lambda (p) (with-output-to-port p thunk))))
 +
 +(define (with-error-to-file file thunk)
 +  "THUNK must be a procedure of no arguments, and FILE must be a
 +string naming a file.  The effect is unspecified if the file already exists. 
 +The file is opened for output, an output port connected to it is made
 +the default value returned by `current-error-port', 
 +and the THUNK is called with no arguments.
 +When the THUNK returns, the port is closed and the previous
 +default is restored.  Returns the values yielded by THUNK.  If an
 +escape procedure is used to escape from the continuation of these
 +procedures, their behavior is implementation dependent."
 +  (call-with-output-file file
 +   (lambda (p) (with-error-to-port p thunk))))
 +
 +(define (call-with-input-string string proc)
 +  "Calls the one-argument procedure @var{proc} with a newly created
 +input port from which @var{string}'s contents may be read.  The value
 +yielded by the @var{proc} is returned."
 +  (proc (open-input-string string)))
 +
 +(define (with-input-from-string string thunk)
 +  "THUNK must be a procedure of no arguments.
 +The test of STRING  is opened for
 +input, an input port connected to it is made, 
 +and the THUNK is called with no arguments.
 +When the THUNK returns, the port is closed.
 +Returns the values yielded by THUNK.  If an
 +escape procedure is used to escape from the continuation of these
 +procedures, their behavior is implementation dependent."
 +  (call-with-input-string string
 +   (lambda (p) (with-input-from-port p thunk))))
 +
 +(define (call-with-output-string proc)
 +  "Calls the one-argument procedure @var{proc} with a newly created output
 +port.  When the function returns, the string composed of the characters
 +written into the port is returned."
 +  (let ((port (open-output-string)))
 +    (proc port)
 +    (get-output-string port)))
 +
 +(define (with-output-to-string thunk)
 +  "Calls THUNK and returns its output as a string."
 +  (call-with-output-string
 +   (lambda (p) (with-output-to-port p thunk))))
 +
 +(define (with-error-to-string thunk)
 +  "Calls THUNK and returns its error output as a string."
 +  (call-with-output-string
 +   (lambda (p) (with-error-to-port p thunk))))
 +
 +(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p))))
 +
  \f
  
  ;;; {Booleans}
        (lambda (str)
          (->bool (stat str #f)))
        (lambda (str)
 -        (let ((port (catch 'system-error (lambda () (open-file str OPEN_READ))
 +        (let ((port (catch 'system-error (lambda () (open-input-file str))
                             (lambda args #f))))
            (if port (begin (close-port port) #t)
                #f)))))
          (eq? (stat:type (stat str)) 'directory))
        (lambda (str)
          (let ((port (catch 'system-error
 -                           (lambda () (open-file (string-append str "/.")
 -                                                 OPEN_READ))
 +                           (lambda ()
 +                             (open-input-file (string-append str "/.")))
                             (lambda args #f))))
            (if port (begin (close-port port) #t)
                #f)))))
      ((define-record-type
         (lambda (x)
           (define (make-id scope . fragments)
 -           (datum->syntax #'scope
 +           (datum->syntax scope
                            (apply symbol-append
                                   (map (lambda (x)
                                          (if (symbol? x) x (syntax->datum x)))
  ;; initial uses list, or binding procedure.
  ;;
  (define* (make-module #:optional (size 31) (uses '()) (binder #f))
 -  (define %default-import-size
 -    ;; Typical number of imported bindings actually used by a module.
 -    600)
 -
    (if (not (integer? size))
        (error "Illegal size to make-module." size))
    (if (not (and (list? uses)
    (let ((module (module-constructor (make-hash-table size)
                                      uses binder #f macroexpand
                                      #f #f #f
 -                                    (make-hash-table %default-import-size)
 +                                    (make-hash-table)
                                      '()
                                      (make-weak-key-hash-table 31) #f
                                      (make-hash-table 7) #f #f #f)))
  (define (module-define-submodule! module name submodule)
    (hashq-set! (module-submodules module) name submodule))
  
 -;; It used to be, however, that module names were also present in the
 -;; value namespace. When we enable deprecated code, we preserve this
 -;; legacy behavior.
 -;;
 -;; These shims are defined here instead of in deprecated.scm because we
 -;; need their definitions before loading other modules.
 -;;
 -(begin-deprecated
 - (define (module-ref-submodule module name)
 -   (or (hashq-ref (module-submodules module) name)
 -       (and (module-submodule-binder module)
 -            ((module-submodule-binder module) module name))
 -       (let ((var (module-local-variable module name)))
 -         (and var (variable-bound? var) (module? (variable-ref var))
 -              (begin
 -                (warn "module" module "not in submodules table")
 -                (variable-ref var))))))
 -
 - (define (module-define-submodule! module name submodule)
 -   (let ((var (module-local-variable module name)))
 -     (if (and var
 -              (or (not (variable-bound? var))
 -                  (not (module? (variable-ref var)))))
 -         (warn "defining module" module ": not overriding local definition" var)
 -         (module-define! module name submodule)))
 -   (hashq-set! (module-submodules module) name submodule)))
 -
  \f
  
  ;;; {Module-based Loading}
@@@ -3252,6 -2969,98 +3253,6 @@@ module '(ice-9 q) '(make-q q-length))}.
  
  \f
  
 -;;; {Parameters}
 -;;;
 -
 -(define <parameter>
 -  ;; Three fields: the procedure itself, the fluid, and the converter.
 -  (make-struct <applicable-struct-vtable> 0 'pwprpr))
 -(set-struct-vtable-name! <parameter> '<parameter>)
 -
 -(define* (make-parameter init #:optional (conv (lambda (x) x)))
 -  (let ((fluid (make-fluid (conv init))))
 -    (make-struct <parameter> 0
 -                 (case-lambda
 -                   (() (fluid-ref fluid))
 -                   ((x) (let ((prev (fluid-ref fluid)))
 -                          (fluid-set! fluid (conv x))
 -                          prev)))
 -                 fluid conv)))
 -
 -(define (parameter? x)
 -  (and (struct? x) (eq? (struct-vtable x) <parameter>)))
 -
 -(define (parameter-fluid p)
 -  (if (parameter? p)
 -      (struct-ref p 1)
 -      (scm-error 'wrong-type-arg "parameter-fluid"
 -                 "Not a parameter: ~S" (list p) #f)))
 -
 -(define (parameter-converter p)
 -  (if (parameter? p)
 -      (struct-ref p 2)
 -      (scm-error 'wrong-type-arg "parameter-fluid"
 -                 "Not a parameter: ~S" (list p) #f)))
 -
 -(define-syntax parameterize
 -  (lambda (x)
 -    (syntax-case x ()
 -      ((_ ((param value) ...) body body* ...)
 -       (with-syntax (((p ...) (generate-temporaries #'(param ...))))
 -         #'(let ((p param) ...)
 -             (if (not (parameter? p))
 -                        (scm-error 'wrong-type-arg "parameterize"
 -                                   "Not a parameter: ~S" (list p) #f))
 -             ...
 -             (with-fluids (((struct-ref p 1) ((struct-ref p 2) value))
 -                           ...)
 -               body body* ...)))))))
 -
 -\f
 -;;;
 -;;; Current ports as parameters.
 -;;;
 -
 -(let ((fluid->parameter
 -       (lambda (fluid conv)
 -         (make-struct <parameter> 0
 -                      (case-lambda
 -                        (() (fluid-ref fluid))
 -                        ((x) (let ((prev (fluid-ref fluid)))
 -                               (fluid-set! fluid (conv x))
 -                               prev)))
 -                      fluid conv))))
 -  (define-syntax-rule (port-parameterize! binding fluid predicate msg)
 -    (begin
 -      (set! binding (fluid->parameter (module-ref (current-module) 'fluid)
 -                                      (lambda (x)
 -                                        (if (predicate x) x
 -                                            (error msg x)))))
 -      (module-remove! (current-module) 'fluid)))
 -  
 -  (port-parameterize! current-input-port %current-input-port-fluid
 -                      input-port? "expected an input port")
 -  (port-parameterize! current-output-port %current-output-port-fluid
 -                      output-port? "expected an output port")
 -  (port-parameterize! current-error-port %current-error-port-fluid
 -                      output-port? "expected an output port"))
 -
 -
 -\f
 -;;;
 -;;; Warnings.
 -;;;
 -
 -(define current-warning-port
 -  (make-parameter (current-error-port)
 -                  (lambda (x)
 -                    (if (output-port? x)
 -                        x
 -                        (error "expected an output port" x)))))
 -
 -
 -\f
 -
  ;;; {Running Repls}
  ;;;
  
               (process-use-modules (list quoted-args ...))
               *unspecified*))))))
  
 -(define-syntax-rule (use-syntax spec ...)
 -  (begin
 -    (eval-when (eval load compile expand)
 -      (issue-deprecation-warning
 -       "`use-syntax' is deprecated. Please contact guile-devel for more info."))
 -    (use-modules spec ...)))
 -
  (include-from-path "ice-9/r6rs-libraries")
  
  (define-syntax-rule (define-private foo bar)