Scheme-PLUS-for-Racket/def-function.rkt at main · damien-mattei/Scheme-PLUS-for-Racket · GitHub

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
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139

;; This file is part of Scheme+

;; Copyright 2021-2025 Damien MATTEI

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.


;; for internal use only , see def for the extern use

(module def-function racket/base


	(provide def return return-rec)

	(require srfi/31 ;; for 'rec in def*
		 Scheme+/return
		 racket/stxparam
		 (for-syntax racket/base))


;; Welcome to DrRacket, version 8.14 [cs].
;; Language: racket, with debugging; memory limit: 8192 MB.
;; > (require Scheme+/def-function)
;; > (def (foo) (display "hello") (newline) (return) (display "world") (newline))
;; > (foo)
;; hello
;; > (return)
;; return: can only be used inside def


;; scheme@(guile-user)> (def (foo) (when #t (return "hello") "bye"))
;; scheme@(guile-user)> (foo)
;;  "hello"

;; (def x)

;;(define return '()) ;; for debug of Typed Racket


;;(def (foo) (return 1 2 3))

;; (foo)
;; 1
;; 2
;; 3

;; list of the arguments from the formals of a procedure
;; (formals->list (a b)) -> (cons a (cons b '()))
;; (formals->list (a b . L)) -> (cons a (cons b L))
;; (formals->list L) -> L
(define-syntax formals->list

  (syntax-rules ()

    ((_ ()) '())
    ((_ (a . rest)) (cons a (formals->list rest)))
    ((_ r) r)))


(define-syntax def

  (lambda (stx)

      (syntax-case stx ()

	;; multiple definitions without values assigned
	;; (def (x y z))
	;; TODO: remove? redundant with (declare x y z)
	((_ (var1 ...)) #'(begin (define var1 '()) ...))

	;; function definition, with fixed, variadic or only rest arguments
	;; (def (foo a b . L) (when #t (return (list a b L))))
	;; (foo 1 2 3 4)
	;; '(1 2 (3 4))
	((_ (<name> . <formals>) <body> <body>* ...)

	 #'(define (<name> . <formals>)

	     (call/cc

	      (lambda (ret-rec-id)
		;; In the body we adjust the 'return-rec' keyword so that calls
		;; to 'return-rec' are replaced with calls to the escape
		;; continuation.

		(syntax-parameterize
		 ([return-rec (syntax-rules ()
				[(return-rec vals (... ...))
				 (ret-rec-id vals (... ...))])])

		 (apply (letrec ((<name> (lambda <formals>

					   (call/cc

					    (lambda (ret-id)
					      ;; In the body we adjust the 'return' keyword so that calls
					      ;; to 'return' are replaced with calls to the escape
					      ;; continuation.
					      (syntax-parameterize
					       ([return (syntax-rules ()
							  [(return vals (... ...))
							   (ret-id vals (... ...))])])
					       <body> <body>* ...))))))
			  <name>)

			(formals->list <formals>)))))))


	;; single definition without a value assigned
	;; (def x)
	((_ var) #'(define var '()))

	;; (def x 7)
	((_ var expr) #'(define var expr))

	((_ . err) #'(error "Bad def form"))

	)))


) ; end module