~amirouche/sink-kernel

db805d8209bcd7cf70fa9f33f761dcca8de3224d — Amirouche 1 year, 4 months ago 356c07a
make it work
M sink.scm => sink.scm +21 -19
@@ 1,30 1,32 @@
; This file is part of SINK, a Scheme-based Interpreter for Not-quite Kernel
; Copyright (c) 2009 John N. Shutt
;; This file is part of SINK, a Scheme-based Interpreter for Not-quite Kernel
;; Copyright (c) 2009 John N. Shutt

;;;;;;;;;;;;;;;;;;;
; Scheme-based    ;
; Interpreter for ;
; Not-quite       ;
; Kernel          ;
;; Scheme-based    ;
;; Interpreter for ;
;; Not-quite       ;
;; Kernel          ;
;;;;;;;;;;;;;;;;;;;
;
; This is the main file for using SINK in Scheme interactive mode.
; It constructs SINK and displays instructions on how to run SINK.
; The programmer can then run SINK as many times as desired, and whenever
; SINK terminates the programmer is returned to the Scheme prompt.
;; This is the main file for using SINK in Scheme interactive mode.
;; It constructs SINK and displays instructions on how to run SINK.
;; The programmer can then run SINK as many times as desired, and whenever
;; SINK terminates the programmer is returned to the Scheme prompt.
;
; Using MzScheme, to load SINK from the SINK home directory, type either
;; Using MzScheme, to load SINK from the SINK home directory, type either
;
;     mzscheme
;     (load "sink.scm")
; or
;     mzscheme -f sink.scm
;;     mzscheme
;;     (load "sink.scm")
;; or
;;     mzscheme -f sink.scm
;
; SINK was developed under MzScheme version 103.  Although the program is
; mostly limited to R5RS Scheme, some details of Kernel error handling won't
; work on some technically R5RS-compliant platforms (on which, see file
; "subfiles/operative.scm" procedure naive->action).
;; SINK was developed under MzScheme version 103.  Although the program is
;; mostly limited to R5RS Scheme, some details of Kernel error handling won't
;; work on some technically R5RS-compliant platforms (on which, see file
;; "subfiles/operative.scm" procedure naive->action).
;
(import (chezscheme))


(load "subfiles/all.scm")


M subfiles/context.scm => subfiles/context.scm +15 -15
@@ 51,7 51,7 @@
;
;   'alist is a list of keyed-bindings, constructed by tools in file
; "subfiles/keyed.scm".
; 
;
;   'mark is a pair, unique to this context, whose car is a boolean.  Its
; car is #f except during ancestry-determination algorithms.  A context
; whose mark's car is #t is said to be "marked".  Marking contexts allows


@@ 97,19 97,19 @@
;
;   The top-level context's alist is provided by
; make-top-level-dynamic-alist.
;    
;
(define make-top-level-context
  (lambda (error-handler)
    (call-with-current-continuation
      (lambda (c)
        (letrec ((receiver
        (letrec* ((receiver
                   (lambda ignore (c normal-context)))
                 (alist
                   (make-top-level-dynamic-alist))
                 (terminal-context
                   (let ((delegate  (make-context
                                      (lambda ignore (c ()))
                                      () () () () () alist)))
                                      (lambda ignore (c '()))
                                      '() '() '() '() '() alist)))
                     (lambda (message)
                       (case message
                         ((error-context)     error-context)


@@ 119,7 119,7 @@
                   (let ((delegate  (make-context
                                      (lambda (ed)
                                        (receiver (error-handler ed)))
                                      () () () () () alist)))
                                      '() '() '() '() '() alist)))
                     (lambda (message)
                       (case message
                         ((parent)            terminal-context)


@@ 129,7 129,7 @@
                 (normal-context
                   (let ((delegate  (make-context
                                      receiver
                                      () () () () () alist)))
                                      '() '() '() '() '() alist)))
                     (lambda (message)
                       (case message
                         ((parent)            terminal-context)


@@ 173,7 173,7 @@
        (let ((error-context     (parent 'error-context))
              (terminal-context  (parent 'terminal-context))
              (alist             (make-alist (parent 'alist) key value)))
          (proc (make-context receiver parent () ()
          (proc (make-context receiver parent '() '()
                              error-context terminal-context alist)))))))

;


@@ 313,7 313,7 @@

    (lambda (value source destination)
      (set-marks! source #t)
      (let ((selected  (select-entry-interceptors destination ())))
      (let ((selected  (select-entry-interceptors destination '())))
        (set-marks! source #f)
        (set-marks! destination #t)
        (let ((selected  (select-exit-interceptors source selected)))


@@ 356,8 356,8 @@
              (eval (kernel-list (kernel-car operand-tree) context)
                    env context))
            context
            ()
            ()))
            '()
            '()))
        1 1 combiner?)

      'extend-continuation


@@ 376,7 376,7 @@
                            (let ((error-context    (parent 'error-context))
                                  (terminal-context (parent 'terminal-context))
                                  (alist            (parent 'alist)))
                              (c (make-context receiver parent () ()
                              (c (make-context receiver parent '() '()
                                   error-context terminal-context alist)))))))
                  ((parent 'receiver)
                   (eval (kernel-cons (unwrap appv) operand-tree)


@@ 386,7 386,7 @@
      'guard-continuation
      (action->checked-applicative
        (lambda (operand-tree env context)
          (let* ((divert  ())
          (let* ((divert  '())
                 (convert-clause
                   (lambda (clause)
                     (let ((selector     (kernel-car clause))


@@ 414,11 414,11 @@
                                 (set! divert outer-context)
                                 (c inner-context))
                               outer-context
                               ()
                               '()
                               exit-guards))
                           parent
                           entry-guards
                           ())))
                           '())))
                   ((parent 'receiver)
                    operand-tree))))))
        3 3 guards-list? context? guards-list?)

M subfiles/cycles.scm => subfiles/cycles.scm +7 -7
@@ 179,7 179,7 @@
                                       (mapper (- n-pairs 1)
                                               proc
                                               (kernel-cdr ls)))
                            ()))))
                            '()))))
      mapper)))

(define bounded-simple-map       (make-bounded-simple-map kernel-cons))


@@ 228,7 228,7 @@
           (a  (caddr metrics))
           (c  (cadddr metrics)))
      (if (<= p 0)
          ()
          '()
          (let ((ls  (bounded-simple-map p proc ls)))
            (kernel-encycle! ls a c)
            ls)))))


@@ 278,7 278,7 @@
    (define aux
      (lambda (k lss p a c)
        (if (<= k 0)
            ()
            '()
            (let ((x  (bounded-simple-map p kernel-car lss))
                  (y  (bounded-simple-map p kernel-cdr lss)))
              (kernel-encycle! x a c)


@@ 348,7 348,7 @@
(define kernel-equal?
  (lambda (x y)

    (define table ())
    (define table '())

    (define get-row
      (lambda (x)


@@ 467,7 467,7 @@
    ;            (a   (kernel-cadr operand-tree))
    ;            (c   (kernel-caddr operand-tree))
    ;            (p   (car (get-list-metrics ls))))
    ;       (cond ((< c 1)  ())
    ;       (cond ((< c 1)  '())
    ;             ((< p (+ a c))
    ;                (error-pass (make-error-descriptor
    ;                              (list "List isn't long enough"


@@ 540,14 540,14 @@
    ;     (define bounded-append
    ;       (lambda (k lss)
    ;         (if (<= k 0)
    ;             ()
    ;             '()
    ;             (binary-append (kernel-car lss)
    ;                            (bounded-append (- k 1) (kernel-cdr lss))))))
    ;
    ;     (define finite-append
    ;       (lambda (lss)
    ;         (if (null? lss)
    ;             ()
    ;             '()
    ;             (let ((ls   (kernel-car lss))
    ;                   (lss  (kernel-cdr lss)))
    ;               (if (null? lss)

M subfiles/environment.scm => subfiles/environment.scm +6 -6
@@ 145,7 145,7 @@
              (else  #f))))

    (and (not (cyclic-tree? tree))
         (list? (aux tree ())))))
         (list? (aux tree '())))))

;
; Locally binds a parameter-tree to an object.


@@ 157,7 157,7 @@
(define match!
  (lambda (env ptree object)

    (define emsg ()) ; repository for error-descriptor content
    (define emsg '()) ; repository for error-descriptor content

    ; returns arguments for add-bindings-to-frame!
    (define aux


@@ 175,14 175,14 @@
                                   args
                                   (set! emsg
                                         (append emsg
                                            (list (list "  mismatch:  ()  "
                                            (list (list "  mismatch:  '()  "
                                                        (list object)))))))
              (else args)))) ; must be ignore

    (if (not (valid-ptree? ptree))
        (make-error-descriptor "Invalid parameter tree"
                               (list "Parameter tree: " (list ptree)))
        (let ((args  (aux ptree object ())))
        (let ((args  (aux ptree object '())))
          (if (pair? emsg)
              (apply make-error-descriptor
                     "Definiend/object mismatch"


@@ 194,12 194,12 @@
                (apply add-bindings-to-frame!
                       (car (get-environment-frames env))
                       args)
                ()))))))
                '()))))))

;
; Constructs an empty frame.
;
(define make-empty-frame (lambda () (list ())))
(define make-empty-frame (lambda () (list '())))

;
; Performs a series of bind operations in given frame, mutating existing

M subfiles/ground.scm => subfiles/ground.scm +4 -4
@@ 119,7 119,7 @@
;             (result  (assoc key (kernel-list->list alist))))
;        (if (pair? result)
;            result
;            ())))
;            '())))
;    "assoc"
;    2 2 any? kernel-list?)
;;;;;;;;;;;;


@@ 132,7 132,7 @@
;             (result  (assq key (kernel-list->list alist))))
;        (if (pair? result)
;            result
;            ())))
;            '())))
;    "assq"
;    2 2 any? kernel-list?)



@@ 157,7 157,7 @@
                                   (aux (eval object env context)))))))
              (aux inert)))
          context
          (list (cons ()
          (list (cons '()
                      (lambda (v)
                        (error-pass
                          (make-error-descriptor


@@ 165,7 165,7 @@
                                  filename "\"")
                            (list "  Value sent: " (list v)))
                          context))))
          (list (cons ()
          (list (cons '()
                      (lambda (v)
                        (close-kernel-input-port kip context)
                        v))))))

M subfiles/interpreter.scm => subfiles/interpreter.scm +1 -1
@@ 39,7 39,7 @@
                             context)))
      (newline)
      (if (eof-object? exp)
          (terminal-pass () context))
          (terminal-pass '() context))
      (kernel-write (eval exp env context)
                    (get-kernel-current-output-port context)
                    context)

M subfiles/kernel-pair-disjoint.scm => subfiles/kernel-pair-disjoint.scm +6 -6
@@ 160,7 160,7 @@

    ; get-revisits
    (lambda (tree)
      (aux () () tree))))
      (aux '() '() tree))))

(define get-kernel-revisits
  (make-get-revisits kernel-pair? kernel-car kernel-cdr))


@@ 219,7 219,7 @@
                    (let ((content  (cddr record)))
                      (if (pair? content)
                          (begin
                            (set-cdr! (cdr record) ())
                            (set-cdr! (cdr record) '())
                            (set-car! content (aux (in-car tree)))
                            (set-cdr! content (aux (in-cdr tree)))))
                      (cadr record))


@@ 236,7 236,7 @@
    mutable? kernel-car kernel-cdr
    (let ((name  (list #f)))
      (lambda (key)
        (let ((content  (cons () ())))
        (let ((content  (cons '() '())))
          (let ((immutable  (lambda (message)
                              (case message
                                ((type) 'immutable)


@@ 262,7 262,7 @@
  (make-es-copier
    kernel-pair? kernel-car kernel-cdr
    (lambda (key)
      (let* ((kernel-pair  (kernel-cons () ()))
      (let* ((kernel-pair  (kernel-cons '() '()))
             (content      (kernel-pair 'content)))
        (cons key (cons kernel-pair content))))
    kernel-cons


@@ 277,7 277,7 @@
  (make-es-copier
    pair? car cdr
    (lambda (key)
      (let* ((kernel-pair  (kernel-cons () ()))
      (let* ((kernel-pair  (kernel-cons '() '()))
             (content      (kernel-pair 'content)))
        (cons key (cons kernel-pair content))))
    kernel-cons


@@ 339,7 339,7 @@
                  (or (aux ancestors (kernel-car tree))
                      (aux ancestors (kernel-cdr tree))))))))

    (aux () tree)))
    (aux '() tree)))

;
; Given a tree of the interpreted language, output a representation of it to

M subfiles/kernel-pair-overlapping.scm => subfiles/kernel-pair-overlapping.scm +6 -6
@@ 148,7 148,7 @@

    ; get-revisits
    (lambda (tree)
      (aux () () tree))))
      (aux '() '() tree))))

(define get-kernel-revisits
  (make-get-revisits kernel-pair? kernel-car kernel-cdr))


@@ 207,7 207,7 @@
                    (let ((content  (cddr record)))
                      (if (pair? content)
                          (begin
                            (set-cdr! (cdr record) ())
                            (set-cdr! (cdr record) '())
                            (set-car! content (aux (in-car tree)))
                            (set-cdr! content (aux (in-cdr tree)))))
                      (cadr record))


@@ 224,7 224,7 @@
    mutable? kernel-car kernel-cdr
    (let ((name  (list #f)))
      (lambda (key)
        (let ((content  (cons () ())))
        (let ((content  (cons '() '())))
          (let ((immutable  (lambda (message)
                              (case message
                                ((type) 'immutable)


@@ 250,7 250,7 @@
  (make-es-copier
    kernel-pair? kernel-car kernel-cdr
    (lambda (key)
      (let ((content  (cons () ())))
      (let ((content  (cons '() '())))
        (cons key (cons content content))))
    cons
    (lambda (x) x)))


@@ 264,7 264,7 @@
  (make-es-copier
    pair? car cdr
    (lambda (key)
      (let ((content  (cons () ())))
      (let ((content  (cons '() '())))
        (cons key (cons content content))))
    kernel-cons
    (lambda (x)


@@ 324,7 324,7 @@
                  (or (aux ancestors (kernel-car tree))
                      (aux ancestors (kernel-cdr tree))))))))

    (aux () tree)))
    (aux '() tree)))

;
; Given a tree of the interpreted language, output a representation of it to

M subfiles/kernel-pair.scm => subfiles/kernel-pair.scm +6 -6
@@ 160,7 160,7 @@

    ; get-revisits
    (lambda (tree)
      (aux () () tree))))
      (aux '() '() tree))))

(define get-kernel-revisits
  (make-get-revisits kernel-pair? kernel-car kernel-cdr))


@@ 219,7 219,7 @@
                    (let ((content  (cddr record)))
                      (if (pair? content)
                          (begin
                            (set-cdr! (cdr record) ())
                            (set-cdr! (cdr record) '())
                            (set-car! content (aux (in-car tree)))
                            (set-cdr! content (aux (in-cdr tree)))))
                      (cadr record))


@@ 236,7 236,7 @@
    mutable? kernel-car kernel-cdr
    (let ((name  (list #f)))
      (lambda (key)
        (let ((content  (cons () ())))
        (let ((content  (cons '() '())))
          (let ((immutable  (lambda (message)
                              (case message
                                ((type) 'immutable)


@@ 262,7 262,7 @@
  (make-es-copier
    kernel-pair? kernel-car kernel-cdr
    (lambda (key)
      (let* ((kernel-pair  (kernel-cons () ()))
      (let* ((kernel-pair  (kernel-cons '() '()))
             (content      (kernel-pair 'content)))
        (cons key (cons kernel-pair content))))
    kernel-cons


@@ 277,7 277,7 @@
  (make-es-copier
    pair? car cdr
    (lambda (key)
      (let* ((kernel-pair  (kernel-cons () ()))
      (let* ((kernel-pair  (kernel-cons '() '()))
             (content      (kernel-pair 'content)))
        (cons key (cons kernel-pair content))))
    kernel-cons


@@ 339,7 339,7 @@
                  (or (aux ancestors (kernel-car tree))
                      (aux ancestors (kernel-cdr tree))))))))

    (aux () tree)))
    (aux '() tree)))

;
; Given a tree of the interpreted language, output a representation of it to

M subfiles/operative.scm => subfiles/operative.scm +3 -3
@@ 54,7 54,7 @@

    (define aux
      (lambda (p k operands . predicates)
        (cond ((<= k 0)  ())
        (cond ((<= k 0)  '())
              (((car predicates) (kernel-car operands))
                 (apply aux p
                            (- k 1)


@@ 114,7 114,7 @@
    (lambda (operand-tree env context)
      (let ((completed  #f))
        (dynamic-wind
          (lambda () ())
          (lambda () '())
          (lambda () (let ((result  (naive operand-tree)))
                       (set! completed #t)
                       result))


@@ 281,7 281,7 @@
  (lambda (proc arg-list message context)
    (let ((completed  #f))
      (dynamic-wind
        (lambda () ())
        (lambda () '())
        (lambda () (let ((result  (apply proc arg-list)))
                     (set! completed #t)
                     result))

M subfiles/port.scm => subfiles/port.scm +11 -11
@@ 150,16 150,16 @@
; for the Kernel current-input-port and current-output-port.
;

(define get-kernel-current-input-port  ())
(define get-kernel-current-output-port ())
(define get-kernel-current-input-port  '())
(define get-kernel-current-output-port '())

(define call-with-input-context  ())
(define call-with-output-context ())
(define call-with-input-context  '())
(define call-with-output-context '())

(define make-top-level-ports-alist ())
(define make-top-level-ports-alist '())

(let ((make-top-level-input-port-alist  ())
      (make-top-level-output-port-alist  ()))
(let ((make-top-level-input-port-alist  '())
      (make-top-level-output-port-alist  '()))

  (let ((kip-key  (get-fresh-key)))



@@ 176,7 176,7 @@
        (let ((kip  (make-kernel-input-port (current-input-port))))
          (suggest-object-name kip "standard-input-port")
          (make-alist
            ()
            '()
            kip-key
            kip)))))



@@ 195,7 195,7 @@
        (let ((kop  (make-kernel-output-port (current-output-port))))
          (suggest-object-name kop "standard-output-port")
          (make-alist
            ()
            '()
            kop-key
            kop)))))



@@ 354,7 354,7 @@
                 (kip       (open-kernel-input-file name context))
                 (result    (call-with-input-context
                              (lambda (context)
                                (combine combiner () env context))
                                (combine combiner '() env context))
                              context
                              kip)))
            (close-kernel-input-port kip context)


@@ 369,7 369,7 @@
                 (kop       (open-kernel-output-file name context))
                 (result    (call-with-output-context
                              (lambda (context)
                                (combine combiner () env context))
                                (combine combiner '() env context))
                              context
                              kop)))
            (close-kernel-output-port kop context)

M subfiles/revision.scm => subfiles/revision.scm +5 -5
@@ 43,14 43,14 @@
; that the interpreter as a whole has yet to achieve.
;

(define set-version       ())
(define get-version       ())
(define set-version       '())
(define get-version       '())

(define set-revision-date ())
(define get-revision-date ())
(define set-revision-date '())
(define get-revision-date '())

(let ((first-flag     #t)   ; cleared by first call to set-version
      (known-versions ())   ; list of records of the form (version count)
      (known-versions '())   ; list of records of the form (version count)
      (known-year     2007)
      (known-month    8)
      (known-day      4))