From 122102321c5ef7a163dd2da3f2282a4a427d698b Mon Sep 17 00:00:00 2001 From: Damien MATTEI Date: Thu, 18 Apr 2024 17:12:21 +0200 Subject: [PATCH] Version 8.4 --- TODO | 19 +--- examples/SssDyna+.rkt | 52 +++++----- examples/zeta+.rkt | 106 ++++++++++----------- src/SRFI-105.scm | 2 +- src/Scheme+.rkt | 9 +- src/apply-square-brackets.rkt | 68 ++++++------- src/array.rkt | 12 ++- src/assignment.rkt | 173 +++++++++++++++++++++++----------- src/def.scm | 36 ++++++- 9 files changed, 287 insertions(+), 190 deletions(-) diff --git a/TODO b/TODO index c4c66d3..4ff0518 100644 --- a/TODO +++ b/TODO @@ -1,18 +1,7 @@ try to support a R6RS version (fork/branch on github) tester le parsing avec make Makefile -> (define-syntax (defined? stx) - (syntax-case stx () - [(_ id) - (with-syntax ([v (identifier-binding #'id)]) - #''v)])) -> (defined? zz) -#f -> (defined? x) -'(# - x - # - x - 0 - 0 - 0) \ No newline at end of file +use more syntax-case +set values! + +etendre aux arrays le defined? diff --git a/examples/SssDyna+.rkt b/examples/SssDyna+.rkt index 4597b9e..02a8fdf 100644 --- a/examples/SssDyna+.rkt +++ b/examples/SssDyna+.rkt @@ -27,8 +27,8 @@ ;;(require "../Scheme+.rkt") ;;(require Scheme-PLUS-for-Racket/Scheme+) -;;(require "../main.rkt") -(require Scheme-PLUS-for-Racket) +(require "../main.rkt") +;;(require Scheme-PLUS-for-Racket) (require srfi/25) ;; Multi-dimensional Array Primitives @@ -40,6 +40,7 @@ (declare L-init t-init ls dyna cpt) {L-init <- '(1 3 4 16 17 24 45 64 197 256 275 323 540 723 889 915 1040 1041 1093 1099 1111 1284 1344 1520 2027 2500 2734 3000 3267 3610 4285 5027)} + {t-init <- 35267} ;;{t-init <- 21} @@ -135,11 +136,11 @@ ;;(def ls (length L)) ;;(def dyn {dyna[ls t]}) - {ls <+ (length L)} + {ls <- (length L)} ;;(display "ls=") (display ls) (display " ") (display "t=") (display t) (newline) - {dyn <+ dyna[ls t]} + {dyn <- dyna[ls t]} (def c) (def R) @@ -252,7 +253,7 @@ ;; else (let [(R (rest L))] - (if {c > t} ;; continue searching a solution in the rest + (if {c > t} ;; c is too big to be a solution or part of it -> continue searching a solution in the rest (let [(s (ssigma-proto R t))] (array-set! dyna @@ -263,7 +264,7 @@ ;; else ;; c < t at this point - ;; c is part of the solution or his approximation + ;; c is part of the solution (or his approximation) ;; or c is not part of solution (let [(s {(ssigma-proto R {t - c}) or (ssigma-proto R t)})] (array-set! dyna (tf->12 s) @@ -319,11 +320,11 @@ ;; (subset-sum-dyna L-init t-init) -;; #t ;; there exist a solution +;; #t ;; there exists a solution (def (subset-sum-dyna L t) - (declare ls dyn) ;; declare multiple variables + ;;(declare ls dyn) ;; declare multiple variables {ls <- (length L)} {dyn <- dyna[ls t]} @@ -337,13 +338,13 @@ {dyna[ls t] <- 2} (return #f)) - {c <+ (first L)} + {c <- (first L)} (when {c = t} ;; c is the solution {dyna[ls t] <- 1} (return #t)) - {R <+ (rest L)} ;; continue searching a solution in the rest + {R <- (rest L)} ;; continue searching a solution in the rest (declare s) (if {c > t} ;; c is to big to be a solution @@ -395,7 +396,7 @@ (define (subset-sum-condx L t) - (declare ls dyn) ;; declare multiple variables or use <+ instead of <- below + (declare ls dyn) ;; declare multiple variables or use <- instead of <- below {ls <- (length L)} {dyn <- dyna[ls t]} @@ -405,19 +406,19 @@ (condx [{dyn <> 0} (one? dyn)] [(null? L) {dyna[ls t] <- 2} #f] ;; return #f - [exec {c <+ (first L)}] + [exec {c <- (first L)}] ;; c is the solution [{c = t} {dyna[ls t] <- 1} #t] ;; return #t - [exec {R <+ (rest L)}] + [exec {R <- (rest L)}] ;; continue searching a solution in the rest - [{c > t} {s <+ (subset-sum-condx R t)} + [{c > t} {s <- (subset-sum-condx R t)} {dyna[ls t] <- (tf->12 s)} s] ;; return boolean value ;; else : c < t at this point ;; c is part of a solution OR not part of a solution - [else {s <+ (subset-sum-condx R {t - c}) or (subset-sum-condx R t)} + [else {s <- (subset-sum-condx R {t - c}) or (subset-sum-condx R t)} {dyna[ls t] <- (tf->12 s)} s])) ;; return boolean value @@ -427,8 +428,8 @@ (define (subset-sum L t) - {ls <+ (length L)} - {dyn <+ dyna[ls t]} + {ls <- (length L)} + {dyn <- dyna[ls t]} {cpt <- cpt + 1} ;; cpt has been already defined at toplevel @@ -437,19 +438,19 @@ (condx [{dyn <> 0} (one? dyn)] [(null? L) {dyna[ls t] <- 2} #f] ;; return #f - [exec {c <+ (first L)}] + [exec {c <- (first L)}] ;; c is the solution [{c = t} {dyna[ls t] <- 1} #t] ;; return #t - [exec {R <+ (rest L)}] + [exec {R <- (rest L)}] ;; continue searching a solution in the rest - [{c > t} {s <+ (subset-sum R t)} + [{c > t} {s <- (subset-sum R t)} {dyna[ls t] <- (tf->12 s)} s] ;; return boolean value ;; else : c < t at this point ;; c is part of a solution OR not part of a solution - [else {s <+ (subset-sum R {t - c}) or (subset-sum R t)} + [else {s <- (subset-sum R {t - c}) or (subset-sum R t)} {dyna[ls t] <- (tf->12 s)} s])) ;; return boolean value @@ -500,6 +501,15 @@ ;; > (subset-sum-value '(17 24 45 64 197 256 323 540 723 889 915 1040 1041 1093 1111 1284 1344 1520 2027 2500 2734 3000 3267 4285 5027) t-init) ;; #f + +;; > (subset-sum-value L-init t-init) +;; '(1 3 4 16 17 24 45 64 197 256 275 323 540 889 915 1040 1041 1093 1099 1111 1344 1520 2027 2500 2734 3267 3610 4285 5027) +;; > t-init +;; 35267 +;; > (+ 1 3 4 16 17 24 45 64 197 256 275 323 540 889 915 1040 1041 1093 1099 1111 1344 1520 2027 2500 2734 3267 3610 4285 5027) +;; 35267 + + (define (subset-sum-value L t) ;; declaration on top diff --git a/examples/zeta+.rkt b/examples/zeta+.rkt index ac8c5d9..48bbf61 100644 --- a/examples/zeta+.rkt +++ b/examples/zeta+.rkt @@ -13,19 +13,19 @@ (define animation-mode #t) -{xws ⥆ 1000} ;; X window size -{yws ⥆ 800} ;; Y window size +{xws ← 1000} ;; X window size +{yws ← 800} ;; Y window size -{ywsp ⥆ yws - 200} ;; Y window size for plot +{ywsp ← yws - 200} ;; Y window size for plot ; Make a frame by instantiating the frame% class -{frame0 ⥆ (new frame% [label "Example"] +{frame0 ← (new frame% [label "Example"] [width xws] [height yws])} ; Make a static text message in the frame -{msg ⥆ (new message% [parent frame0] +{msg ← (new message% [parent frame0] [label "No events so far..."])} ;; Make a button in the frame @@ -43,16 +43,16 @@ ;;{z ⥆ 0} ;;{z ⥆ 2+1i} -{z ⥆ 1.13+1.765i} +{z ← 1.13+1.765i} -{unit-axis-in-pixel ⥆ 200} +{unit-axis-in-pixel ← 200} (define (draw-z-point dc) (send dc set-pen no-pen) (send dc set-brush blue-brush) - {ga ⥆ 8} - {pa ⥆ 8} + {ga ← 8} + {pa ← 8} {(x y) ⥆ (to-screen-multi-values z)} {x ← x - (quotient ga 2)} {y ← y - (quotient pa 2)} @@ -60,18 +60,18 @@ ;; convert to screen coords (define (to-screen z0) - {re ⥆ (real-part z0)} - {im ⥆ (imag-part z0)} - {xs ⥆ re * unit-axis-in-pixel} - {ys ⥆ im * unit-axis-in-pixel} + {re ← (real-part z0)} + {im ← (imag-part z0)} + {xs ← re * unit-axis-in-pixel} + {ys ← im * unit-axis-in-pixel} (make-rectangular (round {xo + xs}) (round {yo - ys}))) (define (to-screen-multi-values z0) - {re ⥆ (real-part z0)} - {im ⥆ (imag-part z0)} - {xs ⥆ re * unit-axis-in-pixel} - {ys ⥆ im * unit-axis-in-pixel} + {re ← (real-part z0)} + {im ← (imag-part z0)} + {xs ← re * unit-axis-in-pixel} + {ys ← im * unit-axis-in-pixel} (values (round {xo + xs}) (round {yo - ys}))) @@ -81,31 +81,31 @@ (define (draw-zeta dc) - {zi ⥆ 0} - {nmax ⥆ 10000000} + {zi ← 0} + {nmax ← 10000000} - {flag-color ⥆ #t} + {flag-color ← #t} ;;(newline) - (for ({n <+ 1} {n <= nmax} {n <- n + 1}) + (for ({n ← 1} {n <= nmax} {n <- n + 1}) (if flag-color (send dc set-pen "blue" 1 'solid) (send dc set-pen "green" 1 'solid)) {flag-color ← (not flag-color)} ;;(display "draw-zeta : n =") (display n) (newline) - {zp ⥆ 1.0 / n ** z} + {zp ← 1.0 / n ** z} ;; (display "draw-zeta : z =") (display z) (newline) ;; (display "draw-zeta : zp =") (display zp) (newline) ;; (display "draw-zeta : zi =") (display zi) (newline) - {zxtrm ⥆ zi + zp} + {zxtrm ← zi + zp} ;;(display "draw-zeta : zxtrm =") (display zxtrm) (newline) - {zie ⥆ (to-screen zi)} + {zie ← (to-screen zi)} ;;(display "draw-zeta : zie =") (display zie) (newline) - {zxtrme ⥆ (to-screen zxtrm)} + {zxtrme ← (to-screen zxtrm)} ;;(display "draw-zeta : zxtrme =") (display zxtrme) (newline) - {x0 ⥆ (real-part zie)} - {y0 ⥆ (imag-part zie)} - {x1 ⥆ (real-part zxtrme)} - {y1 ⥆ (imag-part zxtrme)} + {x0 ← (real-part zie)} + {y0 ← (imag-part zie)} + {x1 ← (real-part zxtrme)} + {y1 ← (imag-part zxtrme)} (when {x0 >= 0 and x0 <= xws and x1 >= 0 and x1 <= xws and y0 >= 0 and y0 <= ywsp and y1 >= 0 and y1 <= ywsp} (send dc draw-line @@ -116,10 +116,10 @@ (define (draw-zeta-multi-values dc) - {zi ⥆ 0} - {flag-color ⥆ #t} - {dmin ⥆ 2} ;; minimal length in pixel to draw line - {n ⥆ 1} + {zi ← 0} + {flag-color ← #t} + {dmin ← 2} ;; minimal length in pixel to draw line + {n ← 1} (newline) (repeat @@ -129,8 +129,8 @@ (send dc set-pen "green" 1 'solid)) {flag-color ← (not flag-color)} ;;(display "draw-zeta-multi-values : n =") (display n) (newline) - {zp ⥆ 1.0 / n ** z} - {zxtrm ⥆ zi + zp} + {zp ← 1.0 / n ** z} + {zxtrm ← zi + zp} ;;(display "draw-zeta-multi-values : zxtrm =") (display zxtrm) (newline) {(x0 y0) ⥆ (to-screen-multi-values zi)} @@ -142,7 +142,7 @@ x0 y0 x1 y1)) - {len-line ⥆ (line-length x0 y0 x1 y1)} + {len-line ← (line-length x0 y0 x1 y1)} {zi ← zxtrm} {n ← n + 1} @@ -175,23 +175,23 @@ ;; [callback (λ (button event) ;; (send msg set-label "Right click"))]) -{z-old ⥆ z} +{z-old ← z} ; Derive a new canvas (a drawing window) class to handle events -{my-canvas% ⥆ +{my-canvas% ← (class canvas% ; The base class is canvas% ; Define overriding method to handle mouse events (define/override (on-event event) - {window-x ⥆ (send event get-x)} - {window-y ⥆ (send event get-y)} + {window-x ← (send event get-x)} + {window-y ← (send event get-y)} (when animation-mode {z ← (ret-z window-x window-y)}) ;;{str ⥆ (string-append "(" (number->string window-x) " , " (number->string window-y) ")")} (when {z ≠ z-old} {z-old ← z} - {str ⥆ (number->string z)} + {str ← (number->string z)} (send msg set-label str) (send cv refresh)) @@ -204,7 +204,7 @@ (super-new))} -{cv ⥆ (new my-canvas% [parent frame0] +{cv ← (new my-canvas% [parent frame0] [paint-callback (λ (canvas dc) ;; dc: Drawing Context ;; cf. https://docs.racket-lang.org/draw/overview.html#%28tech._drawing._context%29 @@ -249,25 +249,25 @@ (define (draw-units dc) ;;X - {nun ⥆ (quotient xo unit-axis-in-pixel)} - (for ({n <+ 1} {n <= nun} {n <- n + 1}) - {xu ⥆ xo + n * unit-axis-in-pixel} + {nun ← (quotient xo unit-axis-in-pixel)} + (for ({n ← 1} {n <= nun} {n <- n + 1}) + {xu ← xo + n * unit-axis-in-pixel} (send dc draw-line xu {yo - 3} xu {yo + 3}) - {xum ⥆ xo - n * unit-axis-in-pixel} + {xum ← xo - n * unit-axis-in-pixel} (send dc draw-line xum {yo - 3} xum {yo + 3})) ;; Y - {nuny ⥆ (quotient yo unit-axis-in-pixel)} - (for ({n <+ 1} {n <= nuny} {n <- n + 1}) - {yu ⥆ yo - n * unit-axis-in-pixel} + {nuny ← (quotient yo unit-axis-in-pixel)} + (for ({n ← 1} {n <= nuny} {n <- n + 1}) + {yu ← yo - n * unit-axis-in-pixel} (send dc draw-line {xo - 3} yu {xo + 3} yu) - {yum ⥆ yo + n * unit-axis-in-pixel} + {yum ← yo + n * unit-axis-in-pixel} (send dc draw-line {xo - 3} yum {xo + 3} yum))) @@ -276,10 +276,10 @@ ;; return the z complex from canvas plane where is the mouse pointer (define (ret-z x y) - {i ⥆ 0+1i} ;; imaginaire pur - {re ⥆ x - xo} + {i ← 0+1i} ;; imaginaire pur + {re ← x - xo} {re ← re / unit-axis-in-pixel} - {im ⥆ (- {y - yo})} ;; or yo - y + {im ← (- {y - yo})} ;; or yo - y {im ← im / unit-axis-in-pixel} (exact->inexact {re + i * im})) diff --git a/src/SRFI-105.scm b/src/SRFI-105.scm index ca48c58..f5a2d2f 100644 --- a/src/SRFI-105.scm +++ b/src/SRFI-105.scm @@ -282,7 +282,7 @@ (define (parser-$bracket-apply$next-arguments port prefix) ;; create ($bracket-apply$next container (list args1 args2 ...)) (list '$bracket-apply$next - prefix ;; = container + prefix ;; = container (vector,array,hash table ....) (cons 'list (optimizer-parse-square-brackets-arguments (my-read-delimited-list neoteric-read-real #\] port))))) diff --git a/src/Scheme+.rkt b/src/Scheme+.rkt index 329e5dd..55855e3 100644 --- a/src/Scheme+.rkt +++ b/src/Scheme+.rkt @@ -2,7 +2,7 @@ ;; Scheme+.rkt -;; version 8.2 +;; version 8.4 ;; author: Damien MATTEI @@ -42,7 +42,8 @@ (module Scheme+ racket - + + ;; TODO: try to remove the test, it seems no more used by pkgd (module test racket/base) ;; dummy @@ -137,7 +138,7 @@ (require (for-syntax r6rs/private/base-for-syntax)) ;; for macro syntax (for ... : stxparam.rkt identifier-syntax: undefined - ;(require "infix-operators.rkt") + (require "infix-operators.rkt") ; not mandatory (require "overload.rkt") (require "array.rkt") @@ -164,7 +165,7 @@ (include "increment.scm") (include "for_next_step.scm") - ;;(include "scheme-infix.rkt") + (include "scheme-infix.rkt") ; not mandatory (include "assignment.rkt") (include "apply-square-brackets.rkt") diff --git a/src/apply-square-brackets.rkt b/src/apply-square-brackets.rkt index 63a6e84..62e94f7 100644 --- a/src/apply-square-brackets.rkt +++ b/src/apply-square-brackets.rkt @@ -61,14 +61,14 @@ ;; {#(1 2 3 4 5 6 7)[2 * 5 - 8 $ 3 * 5 - 10 $ 2 * 4 - 6]} ;; '#(3 5) -;; (define ($bracket-apply$ container . args-brackets) ;; this implements a possible $bracket-apply$ as proposed in SRFI-105 +(define ($bracket-apply$ container . args-brackets) ;; this implements a possible $bracket-apply$ as proposed in SRFI-105 -;; ;;(display args-brackets) (newline) -;; ($bracket-apply$next container (parse-square-brackets-arguments args-brackets))) + ;;(display args-brackets) (newline) + ($bracket-apply$next container (parse-square-brackets-arguments args-brackets))) -(define ($bracket-apply$next container args) +(define ($bracket-apply$next container args) ; list of arguments ;;(display "apply-square-brackets.* : $bracket-apply$next : container = ") (display container) (newline) ;;(display args) (newline) @@ -870,46 +870,46 @@ ;; TODO :this code is only here to use Scheme+ but it should be in other place (scheme-infix.rkt) ;; split the expression using slice as separator -;; (def (parse-square-brackets-arguments args-brackets) +(def (parse-square-brackets-arguments args-brackets) -;; ;;(display "apply-square-brackets.* : parse-square-brackets-arguments : args-brackets=") (display args-brackets) (newline) + ;;(display "apply-square-brackets.* : parse-square-brackets-arguments : args-brackets=") (display args-brackets) (newline) -;; (when (null? args-brackets) -;; (return args-brackets)) + (when (null? args-brackets) + (return args-brackets)) -;; ;; closure including pbsa, result and partial-result are lists -;; (declare result partial-result) + ;; closure including pbsa, result and partial-result are lists + (declare result partial-result) -;; (def (psba args) ;; parse square brackets arguments - -;; ;;(display "psba : args=") (display args) (newline) -;; ;;(display "psba : partial-result =") (display partial-result) (newline) -;; (when (null? args) -;; ;;(display "before !*prec") (newline) -;; (<- result (append result (!*prec partial-result))) ;; !*prec is defined in scheme-infix.rkt -;; ;;(display "after !*prec") (newline) -;; ;;(display result) (newline) -;; ;;(display "return-rec") (newline) -;; (return-rec result)) ;; return from all recursive calls + (def (psba args) ;; parse square brackets arguments + + ;;(display "psba : args=") (display args) (newline) + ;;(display "psba : partial-result =") (display partial-result) (newline) + (when (null? args) + ;;(display "before !*prec") (newline) + (<- result (append result (!*prec partial-result))) ;; !*prec is defined in scheme-infix.rkt + ;;(display "after !*prec") (newline) + ;;(display result) (newline) + ;;(display "return-rec") (newline) + (return-rec result)) ;; return from all recursive calls -;; (<+ fst (car args)) + (<+ fst (car args)) -;; (if (equal? slice fst) + (if (equal? slice fst) -;; ($> -;; (when (not (null? partial-result)) -;; (<- result (append result (!*prec partial-result))) ;; evaluate and store the expression -;; (<- partial-result '())) ;; empty for the next possible portion between slice operator -;; (<- result (append result (list fst)))) ;; append the slice operator + ($> + (when (not (null? partial-result)) + (<- result (append result (!*prec partial-result))) ;; evaluate and store the expression + (<- partial-result '())) ;; empty for the next possible portion between slice operator + (<- result (append result (list fst)))) ;; append the slice operator -;; (<- partial-result (append partial-result (list fst)))) ;; not a slice operator but append it + (<- partial-result (append partial-result (list fst)))) ;; not a slice operator but append it -;; (psba (cdr args))) ;; end def, recurse + (psba (cdr args))) ;; end def, recurse -;; (<+ rs (psba args-brackets)) ;; initial call -;; ;;(display "parse-square-brackets-arguments : rs=") (display rs) (newline) -;; rs -;; ) + (<+ rs (psba args-brackets)) ;; initial call + ;;(display "parse-square-brackets-arguments : rs=") (display rs) (newline) + rs + ) diff --git a/src/array.rkt b/src/array.rkt index 9440eea..7e2838f 100644 --- a/src/array.rkt +++ b/src/array.rkt @@ -144,10 +144,14 @@ ;; this one is used by array.scm (define (function-array-n-dim-ref array L-reversed-indexes) ;;(display L-reversed-indexes) (newline) - (if (= 1 (length L-reversed-indexes)) - (vector-ref array (negative-vector-index (car L-reversed-indexes) ;; compatible with negative indexes - array)) - (vector-ref (function-array-n-dim-ref array (cdr L-reversed-indexes)) + (if (= 1 (length L-reversed-indexes)) ; base case : array of dimension 1 : vector + ;; vector + (vector-ref array + (negative-vector-index (car L-reversed-indexes) ;; compatible with negative indexes + array)) + + ;; vector of vectors + (vector-ref (function-array-n-dim-ref array (cdr L-reversed-indexes)) ; the sub-array (negative-vector-index (car L-reversed-indexes) array)))) diff --git a/src/assignment.rkt b/src/assignment.rkt index 34e0b1d..4410688 100644 --- a/src/assignment.rkt +++ b/src/assignment.rkt @@ -95,6 +95,7 @@ ;; optimised by parser form ;;((_ (brket-applynext container (lst index index1 ...)) expr) ((_ (brket-applynext container (lst index ...)) expr) ;; possible to have NO index + ;; lst is list ! #`(begin @@ -149,9 +150,13 @@ ;; (display "<- : variable set!") (newline) ;; (display "var =") (display var) (newline) ;; (display "expr =") (display expr) (newline) - #`(set! var expr)) + ;;#`(set! var expr)) ;; (display "after set! : var =") (display var) (newline))) - ;;var)) + ;;var)) + + #`(if-defined var + (set! var expr) + (define var expr))) ;; (declare x y z t) @@ -435,72 +440,128 @@ ;; (assignment-argument-6-and-more container expr args)))) +(define-syntax assignmentnext + + (lambda (stx) + (syntax-case stx () + ;; 0 argument in [] + ;; T[] + ;; {v[] <- #(1 2 3)} + ;; > v + ;;'#(1 2 3) + [(_ container expr (_)) + #'(assignment-argument-0 container expr)] + + ;; 1 argument in [ ] + ;; T[index] + [(_ container expr (_ arg1)) + #'(assignment-argument-1 container arg1 expr)] + + ;; 2 arguments in [ ] + ;; ex: T[i1 :] , T[: i2], T[i1 i2] , T[: :] + ;; {#(1 2 3 4 5)[inexact->exact(floor(2.7)) :]} + ;; '#(3 4 5) + [(_ container expr (_ arg1 arg2)) + #'(assignment-argument-2 container arg1 arg2 expr)] + + ;; 3 arguments in [ ] + ;; T[i1 : i2] , T[i1 i2 i3] , T[: : s] + [(_ container expr (_ arg1 arg2 arg3)) + #'(assignment-argument-3 container arg1 arg2 arg3 expr)] + + ;; 4 arguments in [ ] + ;; T[: i2 : s] , T[i1 : : s] , T[i1 : i3 :] , T[i1 i2 i3 i4] + [(_ container expr (_ arg1 arg2 arg3 arg4)) + #'(assignment-argument-4 container arg1 arg2 arg3 arg4 expr)] + + ;; 5 arguments in [ ] + ;; T[i1 : i3 : s] , T[i1 i2 i3 i4 i5] + [(_ container expr (_ arg1 arg2 arg3 arg4 arg5)) + #'(assignment-argument-5 container arg1 arg2 arg3 arg4 arg5 expr)] + + ;; more than 5 arguments in [ ] + ;; T[i1 i2 i3 i4 i5 i6 ...] + [(_ container expr (lst arg1 arg2 arg3 arg4 arg5 arg6 ...)) + #'(assignment-argument-6-and-more container (lst arg1 arg2 arg3 arg4 arg5 arg6 ...) expr)] + + ))) -(define-syntax assignmentnext - (syntax-rules () +;; (define-syntax assignmentnext - ((_ container expr args) +;; (lambda (stx) + +;; (syntax-case stx () - (case (length args) +;; ((_ container expr args) - ;; 0 argument in [] - ;; T[] - ((0) - ;;(display "assignmentnext : container =") (display container) (newline) - (assignment-argument-0 container expr)) +;; ;; (begin +;; ;; (display "assignmentnext : (syntax->list #'args)=") +;; ;; (display (syntax->list #'args)) +;; ;; (newline) + +;; (case (length (syntax->list #'args)) ; TODO begin (possibly implicit) -> replace by 'cond' + +;; ;; 0 argument in [] +;; ;; T[] +;; ;; {v[] <- #(1 2 3)} +;; ;; +;; ((1) +;; ;;(display "assignmentnext : container =") (display container) (newline) +;; #'(assignment-argument-0 container expr)) - ;; 1 argument in [ ] - ;; T[index] - ((1) (assignment-argument-1 container (first args) expr)) +;; ;; 1 argument in [ ] +;; ;; T[index] +;; ((2) #'(assignment-argument-1 container (first args) expr)) - ;; 2 arguments in [ ] - ;; ex: T[i1 $] , T[$ i2], T[i1 i2] , T[$ $] +;; ;; 2 arguments in [ ] +;; ;; ex: T[i1 :] , T[: i2], T[i1 i2] , T[: :] - ;; {#(1 2 3 4 5)[inexact->exact(floor(2.7)) $]} - ;; '#(3 4 5) - ((2) (assignment-argument-2 container - (first args) - (second args) - expr)) - - ;; 3 arguments in [ ] - ;; T[i1 $ i2] , T[i1 i2 i3] , T[$ $ s] - ((3) (assignment-argument-3 container - (first args) - (second args) - (third args) - expr)) - - - ;; 4 arguments in [ ] - ;; T[$ i2 $ s] , T[i1 $ $ s] , T[i1 $ i3 $] , T[i1 i2 i3 i4] - ((4) (assignment-argument-4 container - (first args) - (second args) - (third args) - (fourth args) - expr)) +;; ;; {#(1 2 3 4 5)[inexact->exact(floor(2.7)) :]} +;; ;; '#(3 4 5) +;; ((3) #'(assignment-argument-2 container +;; (first args) +;; (second args) +;; expr)) + +;; ;; 3 arguments in [ ] +;; ;; T[i1 : i2] , T[i1 i2 i3] , T[: : s] +;; ((4) #'(assignment-argument-3 container +;; (first args) +;; (second args) +;; (third args) +;; expr)) + + +;; ;; 4 arguments in [ ] +;; ;; T[: i2 : s] , T[i1 : : s] , T[i1 : i3 :] , T[i1 i2 i3 i4] +;; ((5) #'(assignment-argument-4 container +;; (first args) +;; (second args) +;; (third args) +;; (fourth args) +;; expr)) - ;; 5 arguments in [ ] - ;; T[i1 $ i3 $ s] , T[i1 i2 i3 i4 i5] - ((5) (assignment-argument-5 container - (first args) - (second args) - (third args) - (fourth args) - (fifth args) - expr)) +;; ;; 5 arguments in [ ] +;; ;; T[i1 : i3 : s] , T[i1 i2 i3 i4 i5] +;; ((6) #'(assignment-argument-5 container +;; (first args) +;; (second args) +;; (third args) +;; (fourth args) +;; (fifth args) +;; expr)) + +;; ;; more than 5 arguments in [ ] +;; ;; T[i1 i2 i3 i4 i5 i6 ...] +;; (else +;; #'(assignment-argument-6-and-more container expr args)))))));) ;one parenthesis for 'begin' - ;; more than 5 arguments in [ ] - ;; T[i1 i2 i3 i4 i5 i6 ...] - (else - (assignment-argument-6-and-more container expr args)))))) @@ -513,10 +574,10 @@ ;; > z ;; 3 ;; USELESS -(define-syntax assign-var - (syntax-rules () +;; (define-syntax assign-var +;; (syntax-rules () - ((_ (var ...) (exp ...)) (begin (set! var exp) ...)))) +;; ((_ (var ...) (exp ...)) (begin (set! var exp) ...)))) diff --git a/src/def.scm b/src/def.scm index 3a510f0..fd3d481 100644 --- a/src/def.scm +++ b/src/def.scm @@ -1,7 +1,7 @@ ;; This file is part of Scheme+ -;; Copyright 2021-2023 Damien MATTEI +;; Copyright 2021-2024 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 @@ -17,6 +17,38 @@ ;; along with this program. If not, see . +; Tests +;; (define x 3) +;; (if (defined? x) 'defined 'not-defined) ; -> defined + +;; (let ([y 4]) +;; (if (defined? y) 'defined 'not-defined)) ; -> defined + +;; (if (defined? z) 'defined 'not-defined) ; -> not-defined +;; (define-syntax (defined? stx) +;; (syntax-case stx () +;; [(_ id) +;; (with-syntax ([v (identifier-binding #'id)]) ; Racket feature , not RnRS +;; #''v)])) + +; Tests +;; (if-defined z (list z) 'not-defined) ; -> not-defined + +;; (if-defined t (void) (define t 5)) +;; t ; -> 5 + +;; (define x 3) +;; (if-defined x (void) (define x 6)) +;; x ; -> 3 +(define-syntax (if-defined stx) + (syntax-case stx () + [(_ id iftrue iffalse) + (let ([where (identifier-binding #'id)]) + (display "if-defined : where=") (display where) (newline) + (display "id=") (display #'id) (newline)(newline) + (if where #'iftrue #'iffalse))])) + + ;; scheme@(guile-user)> (def (foo) (when #t (return "hello") "bye")) ;; scheme@(guile-user)> (foo) ;; "hello" @@ -26,7 +58,7 @@ ;;(define return '()) ;; for debug of Typed Racket (define-syntax def - + (lambda (stx) (syntax-case stx ()