1 (define *debug-level* 0)

2 (define *debug-indent* 0)

3

4 (define (external-representation o)

5 (let ((p (open-output-string)))

6 (write o p)

7 (get-output-string p)))

8

9 (define (fold-left/index fn acc lis)

10 (let loop ((index 0)

11 (lis lis)

12 (acc acc))

13 (if (null? lis)

14 acc

15 (loop (+ index 1)

16 (cdr lis)

17 (fn index (car lis) acc)))))

18

19 (define (for-each/index fn lis)

20 (let loop ((index 0)

21 (lis lis))

22 (unless (null? lis)

23 (fn index (car lis))

24 (loop (+ index 1) (cdr lis)))))

25

26 (define (describe-object o . pretty)

27 (let ((description (map (lambda (entry)

28 (let ((key (car entry))

29 (val (cdr entry)))

30 (list (slot-name val)

31 (slot-index val)

32 (slot-delegating? val)

33 (slot-kind val)

34 (map (lambda (role)

35 (list (role-positions role)

36 (role-requirements role)

37 (role-method role)))

38 (slot-roles val)))))

39 (hash-table->list (object-layout o)))))

40 (if (or (null? pretty) (car pretty))

41 (pretty-print description))

42 description))

43

44 (define (send/previous-method/missing-handler previous-method missing-handler selector argv)

45 (let* ((method (dispatch previous-method selector argv)))

46 (debug 2 --> 0 "Dispatching to method "method)

47 (if method

48 (let ((code (get-slot method 'code)))

49 (if (procedure? code)

50 (apply code method (vector->list argv))

51 (metalevel-eval-method code method argv)))

52 (missing-handler argv))))

53

54 (define (send/previous-method previous-method selector argv)

55 (send/previous-method/missing-handler previous-method

56 (lambda (argv)

57 (send/previous-method/missing-handler

58 #f

59 (lambda (inner-argv)

60 (error "Dispatch failed"

61 `(send ,selector ,@(vector->list argv))))

62 'notFoundOn:

63 (vector selector argv)))

64 selector

65 argv))

66

67 (define (run-hooks! hooklist)

68 (for-each (lambda (hook) (hook)) (reverse hooklist)))

69

70 (define (curry f . vs)

71 (lambda rest

72 (apply f (append vs rest))))

73

74 (define (non-*false*? x)

75 (if (eq? x *false*)

76 #f

77 x))

78

79 (define (*false*? x)

80 (eq? x *false*))

81

82 (define (vector-fold fn seed v)

83 (let ((len (vector-length v)))

84 (do ((i 0 (+ i 1))

85 (seed seed (fn (vector-ref v i) seed)))

86 ((= i len) seed))))