* warning of missing declaration function but code works
@ 2023-10-02 6:44 Damien Mattei
2023-10-02 8:38 ` Per Bothner
0 siblings, 1 reply; 3+ messages in thread
From: Damien Mattei @ 2023-10-02 6:44 UTC (permalink / raw)
To: kawa mailing list
hello,
is there something to do to remove this sort of warnings on code working:
i searched about java declaration, but instead C++ none are required/existing...
bash-3.2$ kawa -f curly-infix2prefix.scm
/Users/mattei/Dropbox/git/AI_Deep_Learning/exo_retropropagationNhidden_layers_matrix_v2-curly+.rkt
curly-infix2prefix.scm:21:21: warning - no declaration seen for
process-input-code-tail-rec
curly-infix2prefix.scm:28:19: warning - no declaration seen for curly-infix-read
curly-infix2prefix.scm:40:21: warning - no declaration seen for curly-infix-read
curly-infix2prefix.scm:110:27: warning - no declaration seen for read-error
curly-infix2prefix.scm:112:12: warning - no declaration seen for consume-to-eol
curly-infix2prefix.scm:114:11: warning - no declaration seen for
my-char-whitespace?
curly-infix2prefix.scm:122:12: warning - no declaration seen for read-error
curly-infix2prefix.scm:131:21: warning - no declaration seen for
consume-whitespace
curly-infix2prefix.scm:134:24: warning - no declaration seen for read-error
curly-infix2prefix.scm:137:24: warning - no declaration seen for read-error
curly-infix2prefix.scm:160:54: warning - no declaration seen for
neoteric-read-real
curly-infix2prefix.scm:166:47: warning - no declaration seen for
neoteric-read-real
curly-infix2prefix.scm:171:47: warning - no declaration seen for
neoteric-read-real
curly-infix2prefix.scm:209:12: warning - no declaration seen for consume-to-eol
curly-infix2prefix.scm:211:11: warning - no declaration seen for
my-char-whitespace?
curly-infix2prefix.scm:223:37: warning - no declaration seen for
neoteric-read-real
curly-infix2prefix.scm:227:12: warning - no declaration seen for read-error
curly-infix2prefix.scm:231:12: warning - no declaration seen for read-error
curly-infix2prefix.scm:235:12: warning - no declaration seen for read-error
curly-infix2prefix.scm:238:12: warning - no declaration seen for
default-scheme-read
curly-infix2prefix.scm:253:11: warning - no declaration seen for ismember?
curly-infix2prefix.scm:253:23: warning - no declaration seen for digits
curly-infix2prefix.scm:254:12: warning - no declaration seen for read-number
curly-infix2prefix.scm:255:26: warning - no declaration seen for process-sharp
curly-infix2prefix.scm:256:26: warning - no declaration seen for process-period
curly-infix2prefix.scm:259:16: warning - no declaration seen for ismember?
curly-infix2prefix.scm:259:43: warning - no declaration seen for digits
curly-infix2prefix.scm:260:14: warning - no declaration seen for read-number
curly-infix2prefix.scm:261:30: warning - no declaration seen for fold-case-maybe
curly-infix2prefix.scm:263:18: warning - no declaration seen for
read-until-delim
curly-infix2prefix.scm:263:40: warning - no declaration seen for
neoteric-delimiters
curly-infix2prefix.scm:265:28: warning - no declaration seen for fold-case-maybe
curly-infix2prefix.scm:267:16: warning - no declaration seen for
read-until-delim
curly-infix2prefix.scm: note - skipped 0 errors, 1 warnings, 0 notes
curly-infix2prefix.scm:438:23: warning - no declaration seen for process-char
The command-line was:
"/opt/homebrew/Cellar/kawa/3.1.1_1/libexec/bin/kawa -f
curly-infix2prefix.scm"
"/Users/mattei/Dropbox/git/AI_Deep_Learning/exo_retropropagationNhidden_layers_matrix_v2-curly+.rkt"
((provide (all-defined-out)) (require srfi/42) (require matrix.rkt)
(include ../Scheme-PLUS-for-Racket/main/Scheme-PLUS-for-Racket/Scheme+.rkt)
(require ../Scheme-PLUS-for-Racket/main/Scheme-PLUS-for-Racket/overload.rkt)
(include ../Scheme-PLUS-for-Racket/main/Scheme-PLUS-for-Racket/assignment.rkt)
(include
../Scheme-PLUS-for-Racket/main/Scheme-PLUS-for-Racket/apply-square-brackets.rkt)
(define-overload-existing-operator +) (define-overload-existing-operator *)
(define-overload-procedure uniform)
(include
../Scheme-PLUS-for-Racket/main/Scheme-PLUS-for-Racket/scheme-infix.rkt)
(overload-existing-operator + vector-append (vector? vector?))
(overload-existing-operator * multiply-flomat-vector (flomat? vector?))
(define (uniform-dummy dummy) (* (random) (if (= (random 2) 0) 1 -1)))
(define (uniform-interval inf sup) (<+ gap (- sup inf))
($nfx$ inf + gap * (random)))
(overload-procedure uniform uniform-dummy (number?))
(overload-procedure uniform uniform-interval (number? number?))
(define (σ z̃) (/ 1 (+ 1 (exp (- z̃)))))
(define (der_tanh z z̃) ($nfx$ 1 - z ** 2))
(define (der_σ z z̃) (* z (- 1 z)))
(define (der_atan z z̃) (/ 1 ($nfx$ 1 + z̃ ** 2)))
(define-syntax reversed
(syntax-rules ()
((_ (name end))
(begin
(unless (equal? (quote in-range) (quote name))
(error first argument is not in-range: (quote name)))
(in-range (- end 1) -1 -1)))
((_ (name start end))
(begin
(unless (equal? (quote in-range) (quote name))
(error first argument is not in-range: (quote name)))
(in-range (- end 1) (- start 1) -1)))))
(define ReseauRetroPropagation
(class object% (super-new)
(init-field (nc #(2 3 1)) (nbiter 10000) (ηₛ 1.0)
(activation_function_hidden_layer tanh)
(activation_function_output_layer tanh)
(activation_function_hidden_layer_derivative der_tanh)
(activation_function_output_layer_derivative der_tanh))
(<+ lnc (vector-length nc))
(field (z (vector-ec (:vector lg nc) (make-vector lg 0)))) (display z=)
(display z) (newline)
(field (z̃ (vector-ec (:vector lg nc) (make-vector lg 0)))) (display z̃=)
(display z̃) (newline) (define-pointwise-unary uniform)
(<+ M
(vector-ec (: n (- lnc 1))
(.uniform!
(zeros ($bracket-apply$ nc n + 1) (+ ($bracket-apply$ nc n) 1)))))
(display M=) (display M) (newline)
(field (ᐁ (for/vector ((lg nc)) (make-vector lg 0)))) (display ᐁ=)
(display ᐁ) (newline) (display nbiter=) (display nbiter) (newline)
(field (error 0))
(define (accepte_et_propage x)
(when (≠ (vector-length x) (vector-length ($bracket-apply$ z 0)))
(display Mauvais nombre d'entrées !) (newline) (exit #f))
(<- ($bracket-apply$ z 0) x) (<+ n (vector-length z)) (declare z_1)
(declare i)
(for ((<- i 0) ($nfx$ i < n - 2) ($nfx$ i <- i + 1))
($nfx$ z_1 <- #(1) + ($bracket-apply$ z i))
($nfx$ ($bracket-apply$ z̃ i + 1) <- ($bracket-apply$ M i) * z_1)
(<- ($bracket-apply$ z i + 1)
(vector-map activation_function_hidden_layer
($bracket-apply$ z̃ i + 1))))
($nfx$ z_1 <- #(1) + ($bracket-apply$ z i))
($nfx$ ($bracket-apply$ z̃ i + 1) <- ($bracket-apply$ M i) * z_1)
(<- ($bracket-apply$ z i + 1)
(vector-map activation_function_output_layer ($bracket-apply$ z̃ i + 1))))
(define/public (apprentissage Lexemples) (<+ ip 0) (declare x y)
(for-racket ((it (in-range nbiter)))
(when ($nfx$ it % 100 = 0) (display it) (newline)) (<+ err 0.0)
(<- (x y) ($bracket-apply$ Lexemples ip)) (accepte_et_propage x)
(<+ i i_output_layer (- (vector-length z) 1))
(<+ ns (vector-length ($bracket-apply$ z i)))
(for-racket ((k (in-range ns)))
($nfx$ ($bracket-apply$ ($bracket-apply$ ᐁ i) k) <- ($bracket-apply$ y k)
- ($bracket-apply$ ($bracket-apply$ z i) k))
($nfx$ err <- err + ($bracket-apply$ ($bracket-apply$ ᐁ i) k) ** 2))
($nfx$ err <- err * 0.5) (when ($nfx$ it = nbiter - 1) (<- error err))
(<+ მzⳆმz̃ activation_function_output_layer_derivative)
(modification_des_poids ($bracket-apply$ M i - 1) ηₛ
($bracket-apply$ z i - 1) ($bracket-apply$ z i) ($bracket-apply$ z̃ i)
($bracket-apply$ ᐁ i) მzⳆმz̃)
(<- მzⳆმz̃ activation_function_hidden_layer_derivative)
(for-racket ((i (reversed (in-range 1 i_output_layer))))
(<+ nc (vector-length ($bracket-apply$ z i)))
(<+ ns (vector-length ($bracket-apply$ z i + 1)))
(for-racket ((j (in-range nc))) (<+ k 0)
(<- ($bracket-apply$ ($bracket-apply$ ᐁ i) j)
(for/sum ((k (in-range ns)))
(*
(მzⳆმz̃ ($bracket-apply$ ($bracket-apply$ z i + 1) k)
($bracket-apply$ ($bracket-apply$ z̃ i + 1) k))
($bracket-apply$ ($bracket-apply$ M i) k (+ j 1))
($bracket-apply$ ($bracket-apply$ ᐁ i + 1) k)))))
(modification_des_poids ($bracket-apply$ M i - 1) ηₛ
($bracket-apply$ z i - 1) ($bracket-apply$ z i) ($bracket-apply$ z̃ i)
($bracket-apply$ ᐁ i) მzⳆმz̃))
(<- ip (random (vector-length Lexemples)))))
(define
(modification_des_poids M_i_o η z_input z_output z̃_output ᐁ_i_o მzⳆმz̃)
(<+ (len_layer_output len_layer_input_plus1forBias) (dim M_i_o))
(<+ len_layer_input (- len_layer_input_plus1forBias 1))
(for-racket ((j (in-range len_layer_output)))
(for-racket ((i (in-range len_layer_input)))
($nfx$ ($bracket-apply$ M_i_o j (+ i 1)) <-
($bracket-apply$ M_i_o j (+ i 1)) -
(* (- η) ($bracket-apply$ z_input i)
(მzⳆმz̃ ($bracket-apply$ z_output j) ($bracket-apply$ z̃_output j))
($bracket-apply$ ᐁ_i_o j))))
($nfx$ ($bracket-apply$ M_i_o j 0) <- ($bracket-apply$ M_i_o j 0) -
(* (- η) 1.0
(მzⳆმz̃ ($bracket-apply$ z_output j) ($bracket-apply$ z̃_output j))
($bracket-apply$ ᐁ_i_o j)))))
(define/public (test Lexemples) (display Test des exemples :) (newline)
(<+ err 0) (declare entree sortie_attendue ᐁ)
(for-racket ((entree-sortie_attendue Lexemples))
(<- (entree sortie_attendue) entree-sortie_attendue)
(accepte_et_propage entree)
(printf ~a --> ~a : on attendait ~a entree
($bracket-apply$ z (vector-length z) - 1) sortie_attendue)
(newline)
($nfx$ ᐁ <- ($bracket-apply$ sortie_attendue 0) -
($bracket-apply$ ($bracket-apply$ z (vector-length z) - 1) 0))
($nfx$ error <- error + ᐁ ** 2))
($nfx$ err <- err * 0.5) (display Error on examples=) (display error)
(newline))))
(printf ################## NOT ##################) (newline)
(<+ r1
(new ReseauRetroPropagation (nc #(1 2 1)) (nbiter 50000) (ηₛ 10)
(activation_function_hidden_layer σ) (activation_function_output_layer σ)
(activation_function_hidden_layer_derivative der_σ)
(activation_function_output_layer_derivative der_σ)))
(<+ Lexemples1 #((#(1) . #(0)) (#(0) . #(1))))
(send r1 apprentissage Lexemples1) (send r1 test Lexemples1) (newline)
(printf ################## XOR ##################) (newline)
(<+ r2
(new ReseauRetroPropagation (nc #(2 3 1)) (nbiter 250000) (ηₛ 10)
(activation_function_hidden_layer σ) (activation_function_output_layer σ)
(activation_function_hidden_layer_derivative der_σ)
(activation_function_output_layer_derivative der_σ)))
(<+ Lexemples2
#((#(1 0) . #(1)) (#(0 0) . #(0)) (#(0 1) . #(1)) (#(1 1) . #(0))))
(send r2 apprentissage Lexemples2) (send r2 test Lexemples2)
(printf ################## SINUS ##################) (newline)
(<+ r3
(new ReseauRetroPropagation (nc #(1 70 70 1)) (nbiter 50000) (ηₛ 0.01)
(activation_function_hidden_layer atan)
(activation_function_output_layer tanh)
(activation_function_hidden_layer_derivative der_atan)
(activation_function_output_layer_derivative der_tanh)))
(<+ Llearning
(vector-ec (:list x (list-ec (: n 10000) (uniform (- pi) pi)))
(cons (vector x) (vector (sin x)))))
(<+ Ltest
(vector-ec (:list x (list-ec (: n 10) (uniform (/ (- pi) 2) (/ pi 2))))
(cons (vector x) (vector (sin x)))))
(send r3 apprentissage Llearning) (send r3 test Ltest))
^ permalink raw reply [flat|nested] 3+ messages in thread
* Re: warning of missing declaration function but code works
2023-10-02 6:44 warning of missing declaration function but code works Damien Mattei
@ 2023-10-02 8:38 ` Per Bothner
2023-10-02 8:56 ` Damien Mattei
0 siblings, 1 reply; 3+ messages in thread
From: Per Bothner @ 2023-10-02 8:38 UTC (permalink / raw)
To: Damien Mattei, kawa mailing list
On 10/1/23 23:44, Damien Mattei via Kawa wrote:
> hello,
> is there something to do to remove this sort of warnings on code working:
>
> i searched about java declaration, but instead C++ none are required/existing...
>
> bash-3.2$ kawa -f curly-infix2prefix.scm
> /Users/mattei/Dropbox/git/AI_Deep_Learning/exo_retropropagationNhidden_layers_matrix_v2-curly+.rkt
> curly-infix2prefix.scm:21:21: warning - no declaration seen for
> process-input-code-tail-rec
Well, you could use the flag --warn-undefined-variable=no
However, I recommend figuring out why the warnings are being emitted, and fixing that.
For one thing, you're likeky to get better performance if the compiler knows
what is going on.
--
--Per Bothner
per@bothner.com http://per.bothner.com/
^ permalink raw reply [flat|nested] 3+ messages in thread
* Re: warning of missing declaration function but code works
2023-10-02 8:38 ` Per Bothner
@ 2023-10-02 8:56 ` Damien Mattei
0 siblings, 0 replies; 3+ messages in thread
From: Damien Mattei @ 2023-10-02 8:56 UTC (permalink / raw)
To: Per Bothner; +Cc: kawa mailing list
[-- Attachment #1: Type: text/plain, Size: 1081 bytes --]
the code was in a message yesterday or before i attached (? french?) it
with other scheme there is no warning ,i suppose it is java related...
but i can not remember why.
On Mon, Oct 2, 2023 at 10:38 AM Per Bothner <per@bothner.com> wrote:
>
>
>
> On 10/1/23 23:44, Damien Mattei via Kawa wrote:
> > hello,
> > is there something to do to remove this sort of warnings on code working:
> >
> > i searched about java declaration, but instead C++ none are required/existing...
> >
> > bash-3.2$ kawa -f curly-infix2prefix.scm
> > /Users/mattei/Dropbox/git/AI_Deep_Learning/exo_retropropagationNhidden_layers_matrix_v2-curly+.rkt
> > curly-infix2prefix.scm:21:21: warning - no declaration seen for
> > process-input-code-tail-rec
>
> Well, you could use the flag --warn-undefined-variable=no
>
> However, I recommend figuring out why the warnings are being emitted, and fixing that.
> For one thing, you're likeky to get better performance if the compiler knows
> what is going on.
> --
> --Per Bothner
> per@bothner.com http://per.bothner.com/
[-- Attachment #2: curly-infix2prefix.scm --]
[-- Type: application/octet-stream, Size: 21370 bytes --]
;; Copyright (C) 2012 David A. Wheeler and Alan Manuel K. Gloria. All Rights Reserved.
;; Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
;; The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
;; modification for Kawa by Damien Mattei
;; use with: kawa curly-infix2prefix.scm file2parse.scm
(define (literal-read-syntax src)
(define in (open-input-file src))
(define lst-code (process-input-code-tail-rec in))
lst-code)
;; read all the expression of program
(define (process-input-code-rec in)
(define result (curly-infix-read in)) ;; read an expression
(if (eof-object? result)
'()
(cons result (process-input-code-rec in))))
;; read all the expression of program
;; a tail recursive version
(define (process-input-code-tail-rec in) ;; in: port
(define (process-input acc)
(define result (curly-infix-read in)) ;; read an expression
(if (eof-object? result)
(reverse acc)
(process-input (cons result acc))))
(process-input '()))
; ------------------------------
; Curly-infix support procedures
; ------------------------------
; Return true if lyst has an even # of parameters, and the (alternating)
; first parameters are "op". Used to determine if a longer lyst is infix.
; If passed empty list, returns true (so recursion works correctly).
(define (even-and-op-prefix? op lyst)
(cond
((null? lyst) #t)
((not (pair? lyst)) #f)
((not (equal? op (car lyst))) #f) ; fail - operators not the same
((not (pair? (cdr lyst))) #f) ; Wrong # of parameters or improper
(#t (even-and-op-prefix? op (cddr lyst))))) ; recurse.
; Return true if the lyst is in simple infix format
; (and thus should be reordered at read time).
(define (simple-infix-list? lyst)
(and
(pair? lyst) ; Must have list; '() doesn't count.
(pair? (cdr lyst)) ; Must have a second argument.
(pair? (cddr lyst)) ; Must have a third argument (we check it
; this way for performance)
(even-and-op-prefix? (cadr lyst) (cdr lyst)))) ; true if rest is simple
; Return alternating parameters in a lyst (1st, 3rd, 5th, etc.)
(define (alternating-parameters lyst)
(if (or (null? lyst) (null? (cdr lyst)))
lyst
(cons (car lyst) (alternating-parameters (cddr lyst)))))
; Not a simple infix list - transform it. Written as a separate procedure
; so that future experiments or SRFIs can easily replace just this piece.
(define (transform-mixed-infix lyst)
(cons '$nfx$ lyst))
; Given curly-infix lyst, map it to its final internal format.
(define (process-curly lyst)
(cond
((not (pair? lyst)) lyst) ; E.G., map {} to ().
((null? (cdr lyst)) ; Map {a} to a.
(car lyst))
((and (pair? (cdr lyst)) (null? (cddr lyst))) ; Map {a b} to (a b).
lyst)
((simple-infix-list? lyst) ; Map {a OP b [OP c...]} to (OP a b [c...])
(cons (cadr lyst) (alternating-parameters lyst)))
(#t (transform-mixed-infix lyst))))
; ------------------------------------------------
; Key procedures to implement neoteric-expressions
; ------------------------------------------------
; Read the "inside" of a list until its matching stop-char, returning list.
; stop-char needs to be closing paren, closing bracket, or closing brace.
; This is like read-delimited-list of Common Lisp.
; This implements a useful extension: (. b) returns b.
(define (my-read-delimited-list my-read stop-char port)
(let*
((c (peek-char port)))
(cond
((eof-object? c) (read-error "EOF in middle of list") '())
((eqv? c #\;)
(consume-to-eol port)
(my-read-delimited-list my-read stop-char port))
((my-char-whitespace? c)
(read-char port)
(my-read-delimited-list my-read stop-char port))
((char=? c stop-char)
(read-char port)
'())
((or (eq? c #\)) (eq? c #\]) (eq? c #\}))
(read-char port)
(read-error "Bad closing character"))
(#t
(let ((datum (my-read port)))
(cond
;; processing period . is important for functions with variable numbers of parameters: (fct arg1 . restargs)
((eq? datum (string->symbol (string #\.))) ;; only this one works with Racket Scheme
;;((eq? datum '.) ;; do not works with Racket Scheme
;;((eq? datum 'period) ;; this one annihilate the processing: datum will never be equal to 'period !
(let ((datum2 (my-read port)))
(consume-whitespace port)
(cond
((eof-object? datum2)
(read-error "Early eof in (... .)\n")
'())
((not (eqv? (peek-char port) stop-char))
(read-error "Bad closing character after . datum"))
(#t
(read-char port)
datum2))))
(#t
(cons datum
(my-read-delimited-list my-read stop-char port)))))))))
; Implement neoteric-expression's prefixed (), [], and {}.
; At this point, we have just finished reading some expression, which
; MIGHT be a prefix of some longer expression. Examine the next
; character to be consumed; if it's an opening paren, bracket, or brace,
; then the expression "prefix" is actually a prefix.
; Otherwise, just return the prefix and do not consume that next char.
; This recurses, to handle formats like f(x)(y).
(define (neoteric-process-tail port prefix)
(let* ((c (peek-char port)))
(cond
((eof-object? c) prefix)
((char=? c #\( ) ; Implement f(x)
(read-char port)
(neoteric-process-tail port
(cons prefix (my-read-delimited-list neoteric-read-real #\) port))))
((char=? c #\[ ) ; Implement f[x]
(read-char port)
(neoteric-process-tail port
(cons '$bracket-apply$
(cons prefix
(my-read-delimited-list neoteric-read-real #\] port)))))
((char=? c #\{ ) ; Implement f{x}
(read-char port)
(neoteric-process-tail port
(let ((tail (process-curly
(my-read-delimited-list neoteric-read-real #\} port))))
(if (eqv? tail '())
(list prefix) ; Map f{} to (f), not (f ()).
(list prefix tail)))))
(#t prefix))))
; To implement neoteric-expressions, modify the reader so
; that [] and {} are also delimiters, and make the reader do this:
; (let* ((prefix
; read-expression-as-usual
; ))
; (if (eof-object? prefix)
; prefix
; (neoteric-process-tail port prefix)))
; Modify the main reader so that [] and {} are also delimiters, and so
; that when #\{ is detected, read using my-read-delimited-list
; any list from that port until its matching #\}, then process
; that list with "process-curly", like this:
; (process-curly (my-read-delimited-list #\} port))
; ------------------------------------------------
; Demo procedures to implement curly-infix and neoteric readers
; ------------------------------------------------
; This implements an entire reader, as a demonstration, but if you can
; update your existing reader you should just update that instead.
; This is a simple R5RS reader, with a few minor (common) extensions.
; The "my-read" is called if it has to recurse.
(define (underlying-read my-read port)
(let* ((c (peek-char port)))
(cond
((eof-object? c) c)
((char=? c #\;)
(consume-to-eol port)
(my-read port))
((my-char-whitespace? c)
(read-char port)
(my-read port))
((char=? c #\( )
(read-char port)
(my-read-delimited-list my-read #\) port))
((char=? c #\[ )
(read-char port)
(my-read-delimited-list my-read #\] port))
((char=? c #\{ )
(read-char port)
(process-curly
(my-read-delimited-list neoteric-read-real #\} port)))
; Handle missing (, [, { :
((char=? c #\) )
(read-char port)
(read-error "Closing parenthesis without opening")
(my-read port))
((char=? c #\] )
(read-char port)
(read-error "Closing bracket without opening")
(my-read port))
((char=? c #\} )
(read-char port)
(read-error "Closing brace without opening")
(my-read port))
((char=? c #\") ; Strings are delimited by ", so can call directly
(default-scheme-read port))
((char=? c #\')
(read-char port)
(list 'quote (my-read port)))
((char=? c #\`)
(read-char port)
(list 'quasiquote (my-read port)))
((char=? c #\,)
(read-char port)
(cond
((char=? #\@ (peek-char port))
(read-char port)
(list 'unquote-splicing (my-read port)))
(#t
(list 'unquote (my-read port)))))
((ismember? c digits) ; Initial digit.
(read-number port '()))
((char=? c #\#) (process-sharp my-read port))
((char=? c #\.) (process-period port))
((or (char=? c #\+) (char=? c #\-)) ; Initial + or -
(read-char port)
(if (ismember? (peek-char port) digits)
(read-number port (list c))
(string->symbol (fold-case-maybe port
(list->string (cons c
(read-until-delim port neoteric-delimiters)))))))
(#t ; Nothing else. Must be a symbol start.
(string->symbol (fold-case-maybe port
(list->string
(read-until-delim port neoteric-delimiters))))))))
(define (curly-infix-read-real port)
(underlying-read curly-infix-read-real port))
(define (curly-infix-read . port)
(if (null? port)
(curly-infix-read-real (current-input-port))
(curly-infix-read-real (car port))))
; Here's a real neoteric reader.
; The key part is that it implements [] and {} as delimiters, and
; after it reads in some datum (the "prefix"), it calls
; neoteric-process-tail to see if there's a "tail".
(define (neoteric-read-real port)
(let* ((prefix (underlying-read neoteric-read-real port)))
(if (eof-object? prefix)
prefix
(neoteric-process-tail port prefix))))
(define (neoteric-read . port)
(if (null? port)
(neoteric-read-real (current-input-port))
(neoteric-read-real (car port))))
; ------------------
; Support procedures
; ------------------
(define digits '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
(define linefeed (integer->char #x000A)) ; #\newline aka \n.
(define carriage-return (integer->char #x000D)) ; \r.
(define tab (integer->char #x0009))
(define line-tab (integer->char #x000b))
(define form-feed (integer->char #x000c))
(define line-ending-chars (list linefeed carriage-return))
(define whitespace-chars
(list tab linefeed line-tab form-feed carriage-return #\space))
; Should we fold case of symbols by default?
; #f means case-sensitive (R6RS); #t means case-insensitive (R5RS).
; Here we'll set it to be case-sensitive, which is consistent with R6RS
; and guile, but NOT with R5RS. Most people won't notice, I
; _like_ case-sensitivity, and the latest spec is case-sensitive,
; so let's start with #f (case-sensitive).
; This doesn't affect character names; as an extension,
; we always accept arbitrary case for them, e.g., #\newline or #\NEWLINE.
(define foldcase-default #f)
; Returns a true value (not necessarily #t) if char ends a line.
(define (char-line-ending? char) (memq char line-ending-chars))
; Returns true if item is member of lyst, else false.
(define (ismember? item lyst)
(pair? (member item lyst)))
; Create own version, in case underlying implementation omits some.
(define (my-char-whitespace? c)
(or (char-whitespace? c) (ismember? c whitespace-chars)))
; If fold-case is active on this port, return string "s" in folded case.
; Otherwise, just return "s". This is needed to support our
; foldcase-default configuration value when processing symbols.
; The "string-foldcase" procedure isn't everywhere,
; so we use "string-downcase".
(define (fold-case-maybe port s)
(if foldcase-default
(string-downcase s)
s))
(define (consume-to-eol port)
; Consume every non-eol character in the current line.
; End on EOF or end-of-line char.
; Do NOT consume the end-of-line character(s).
(let ((c (peek-char port)))
(cond
((not (or (eof-object? c)
(char-line-ending? c)))
(read-char port)
(consume-to-eol port)))))
(define (consume-whitespace port)
(let ((char (peek-char port)))
(cond
((eof-object? char) char)
((eqv? char #\;)
(consume-to-eol port)
(consume-whitespace port))
((my-char-whitespace? char)
(read-char port)
(consume-whitespace port)))))
; Identifying the list of delimiter characters is harder than you'd think.
; This list is based on R6RS section 4.2.1, while adding [] and {},
; but removing "#" from the delimiter set.
; NOTE: R6RS has "#" has a delimiter. However, R5RS does not, and
; R7RS probably will not - http://trac.sacrideo.us/wg/wiki/WG1Ballot3Results
; shows a strong vote AGAINST "#" being a delimiter.
; Having the "#" as a delimiter means that you cannot have "#" embedded
; in a symbol name, which hurts backwards compatibility, and it also
; breaks implementations like Chicken (has many such identifiers) and
; Gambit (which uses this as a namespace separator).
; Thus, this list does NOT have "#" as a delimiter, contravening R6RS
; (but consistent with R5RS, probably R7RS, and several implementations).
; Also - R7RS draft 6 has "|" as delimiter, but we currently don't.
(define neoteric-delimiters
(append (list #\( #\) #\[ #\] #\{ #\} ; Add [] {}
#\" #\;) ; Could add #\# or #\|
whitespace-chars))
(define (read-until-delim port delims)
; Read characters until eof or a character in "delims" is seen.
; Do not consume the eof or delimiter.
; Returns the list of chars that were read.
(let ((c (peek-char port)))
(cond
((eof-object? c) '())
((ismember? c delims) '())
(#t (cons (read-char port) (read-until-delim port delims))))))
(define (read-error message)
(display "Error: ")
(display message)
(display "\n")
'())
(define (read-number port starting-lyst)
(string->number (list->string
(append starting-lyst
(read-until-delim port neoteric-delimiters)))))
; detect #| or |#
(define (nest-comment port)
(let ((c (read-char port)))
(cond
((eof-object? c))
((char=? c #\|)
(let ((c2 (peek-char port)))
(if (char=? c2 #\#)
(read-char port)
(nest-comment port))))
((char=? c #\#)
(let ((c2 (peek-char port)))
(when (char=? c2 #\|)
(begin
(read-char port)
(nest-comment port)))
(nest-comment port)))
(#t
(nest-comment port)))))
(define (process-sharp my-read port)
; We've peeked a # character. Returns what it represents.
(read-char port) ; Remove #
(cond
((eof-object? (peek-char port)) (peek-char port)) ; If eof, return eof.
(#t
; Not EOF. Read in the next character, and start acting on it.
(let ((c (read-char port)))
(cond
((char-ci=? c #\t) #t)
((char-ci=? c #\f) #f)
((ismember? c '(#\i #\e #\b #\o #\d #\x
#\I #\E #\B #\O #\D #\X))
(read-number port (list #\# (char-downcase c))))
((char=? c #\( ) ; Vector.
(list->vector (my-read-delimited-list my-read #\) port)))
;; hash table : #hash(("a" . 1) ("b" . 20)) support to write...
((char=? c #\\) (process-char port))
; This supports SRFI-30 #|...|#
((char=? c #\|) (nest-comment port) (my-read port))
; If #!xyz, consume xyz and recurse.
; In a real reader, consider handling "#! whitespace" per SRFI-22,
; and consider "#!" followed by / or . as a comment until "!#".
((char=? c #\!) (my-read port) (my-read port))
((char=? c #\;) (read-error "SRFI-105 REPL : Unsupported #; extension"))
((char=? c #\') (read-error "SRFI-105 REPL : Unsupported #' extension"))
(#t (read-error (string-append "SRFI-105 REPL :"
"Unsupported # extension"
" unsupported character causing this message is character:"
(string c)))))))))
(define (process-period port)
; We've peeked a period character. Returns what it represents.
(read-char port) ; Remove .
(let ((c (peek-char port)))
(cond ;; processing period . is important for functions with variable numbers of parameters: (fct arg1 . restargs)
((eof-object? c) (string->symbol (string #\.))) ;; only this one works with Racket Scheme
;;((eof-object? c) '.) ; period eof; return period. ;; do not works with Racket Scheme
;;((eof-object? c) 'period) ;; this one annihilate the processing using dummy 'period !
((ismember? c digits)
(read-number port (list #\.))) ; period digit - it's a number.
(#t
; At this point, Scheme only requires support for "." or "...".
; As an extension we can support them all.
(string->symbol
(fold-case-maybe port
(list->string (cons #\.
(read-until-delim port neoteric-delimiters)))))))))
(define (process-char port)
; We've read #\ - returns what it represents.
(cond
((eof-object? (peek-char port)) (peek-char port))
(#t
; Not EOF. Read in the next character, and start acting on it.
(let ((c (read-char port))
(rest (read-until-delim port neoteric-delimiters)))
(cond
((null? rest) c) ; only one char after #\ - so that's it!
(#t
(let ((rest-string (list->string (cons c rest))))
(cond
; Implement R6RS character names, see R6RS section 4.2.6.
; As an extension, we will ALWAYS accept character names
; of any case, no matter what the case-folding value is.
((string-ci=? rest-string "space") #\space)
((string-ci=? rest-string "newline") #\newline)
((string-ci=? rest-string "tab") tab)
((string-ci=? rest-string "nul") (integer->char #x0000))
((string-ci=? rest-string "alarm") (integer->char #x0007))
((string-ci=? rest-string "backspace") (integer->char #x0008))
((string-ci=? rest-string "linefeed") (integer->char #x000A))
((string-ci=? rest-string "vtab") (integer->char #x000B))
((string-ci=? rest-string "page") (integer->char #x000C))
((string-ci=? rest-string "return") (integer->char #x000D))
((string-ci=? rest-string "esc") (integer->char #x001B))
((string-ci=? rest-string "delete") (integer->char #x007F))
; Additional character names as extensions:
((string-ci=? rest-string "ht") tab)
((string-ci=? rest-string "cr") (integer->char #x000d))
((string-ci=? rest-string "bs") (integer->char #x0008))
(#t (read-error "Invalid character name"))))))))))
; Record the original read location, in case it's changed later:
(define default-scheme-read read)
; parse the input file from command line
(define cmd-ln (command-line))
(format #t "The command-line was:~{ ~w~}~%" cmd-ln)
(define file-name (car (reverse cmd-ln)))
(define code (literal-read-syntax file-name))
(display code) (newline)
^ permalink raw reply [flat|nested] 3+ messages in thread
end of thread, other threads:[~2023-10-02 8:56 UTC | newest]
Thread overview: 3+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-10-02 6:44 warning of missing declaration function but code works Damien Mattei
2023-10-02 8:38 ` Per Bothner
2023-10-02 8:56 ` Damien Mattei
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).