File: theme-d-macro-config.scm

package info (click to toggle)
theme-d 1.4.0-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, sid
  • size: 12,784 kB
  • sloc: lisp: 47,684; sh: 4,200; makefile: 455; ansic: 319
file content (118 lines) | stat: -rw-r--r-- 3,527 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
;;;===============================================================================
;;;
;;; Guile compatibility file:
;;;
;;; Uncomment the appropriate LOAD command in macros-core.scm
;;;
;;;===============================================================================

(import (rnrs exceptions))
(import (rnrs lists))
(import (srfi srfi-1))
(import (srfi srfi-9))
(import (ice-9 pretty-print))
(import (th-scheme-utilities stdutils))

;; A numeric string that uniquely identifies this run in the universe
;; TH: We don't need this in Theme-D.
;; (define (ex:unique-token) 
;;   (display "Type a globally unique nonnegative integer: ")
;;   (number->string (read)))
(define (ex:unique-token) "123")

;; The letrec black hole and corresponding setter.

(define ex:undefined '$undefined)
(define ex:undefined-set! 'set!)

;; Single-character symbol prefixes.
;; No builtins may start with one of these.
;; If they do, select different values here.
;; Changed by TH.
;; (define ex:guid-prefix "&")
;; (define ex:free-prefix "~")
(define ex:guid-prefix "&&&")
(define ex:free-prefix "")

(define gl-i-all-exports-size 200)
(define gl-i-modules-size 1000)
(define gl-i-source-exprs-size 10000)
(define gl-i-syntax-source-size 10000)
(define gl-i-orig-names-size 2000)

;; Just give this damn thing a binding

(define assertion-violation 
  (lambda args 
    (display 'assertion-violation)
    (newline)
    (display args)
    (newline)
    (car #f)))

;; (define pretty-print write)

;; These are only partial implementations for specific use cases needed.
;; Full implementations should be provided by host implementation.

;; (define (memp proc ls)
;;   (cond ((null? ls) #f)
;;         ((pair? ls) (if (proc (car ls))
;;                         ls
;;                         (memp proc (cdr ls))))
;;         (else (assertion-violation 'memp "Invalid argument" ls))))

;; (define (filter p? lst)
;;   (if (null? lst)
;;       '()
;;       (if (p? (car lst))
;;           (cons (car lst)
;;                 (filter p? (cdr lst)))
;;           (filter p? (cdr lst)))))

;; (define (for-all proc l . ls)
;;   (or (null? l)
;;       (and (apply proc (car l) (map car ls))
;;            (apply for-all proc (cdr l) (map cdr ls)))))

;; Only the most minimal extremely partial implementation
;; of  r6rs records as needed for our specific use cases.  
;; Note that most arguments are ignored.

;; (define (make-record-type-descriptor name parent uid sealed? opaque? fields)
;;   (list name))

;; (define (make-record-constructor-descriptor rtd parent-constructor-descriptor protocol)
;;   rtd)

;; (define (record-accessor rtd k)
;;   (lambda (r) (vector-ref r (+ k 2))))

;; (define record-constructor #f) 
;; (define record-predicate   #f) 

;; (define (scheme-report-environment nr)
;;   (current-module))

;; (let ((record-tag (list 'record)))

;;   (set! record-constructor 
;;         (lambda (cd) 
;;           (lambda args
;;             (apply vector record-tag cd args))))
        
;;   (set! record-predicate 
;;         (lambda (rtd) 
;;           (let ((real-vector? (eval 'vector? (scheme-report-environment 5))))
;;             (lambda (x)
;;               (and (real-vector? x)
;;                    (eq? (vector-ref x 0) record-tag)
;;                    (eq? (vector-ref x 1) rtd))))))
  
;;   (set! vector?
;;         (let ((real-vector? (eval 'vector? (scheme-report-environment 5))))
;;           (lambda (x)
;;             (and (real-vector? x)
;;                  (not (eq? (vector-ref x 0) record-tag)))))))