X-Git-Url: https://git.gag.com/?a=blobdiff_plain;f=src%2Fscheme%2Fao_scheme_advanced_syntax.scheme;fp=src%2Fscheme%2Fao_scheme_advanced_syntax.scheme;h=79d4ba65ed12b1747ef7c0b8268857f28dd53b8a;hb=16061947d4376b41e596d87f97ec53ec29d17644;hp=0000000000000000000000000000000000000000;hpb=39df849f0717d92a7d5bdf8aa5904bd4db1b467f;p=fw%2Faltos

diff --git a/src/scheme/ao_scheme_advanced_syntax.scheme b/src/scheme/ao_scheme_advanced_syntax.scheme
new file mode 100644
index 00000000..79d4ba65
--- /dev/null
+++ b/src/scheme/ao_scheme_advanced_syntax.scheme
@@ -0,0 +1,402 @@
+;
+; Copyright © 2018 Keith Packard <keithp@keithp.com>
+;
+; 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 2 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.
+;
+; Advanced syntax, including vectors and floats
+
+(begin
+  (def! equal?
+    (lambda (a b)
+      (cond ((eq? a b) #t)
+	    ((and (pair? a) (pair? b))
+	     (and (equal? (car a) (car b))
+		  (equal? (cdr a) (cdr b)))
+	     )
+	    ((and (vector? a) (vector? b) (= (vector-length a) (vector-length b)))
+	     ((lambda (i l)
+		(while (and (< i l)
+			    (equal? (vector-ref a i)
+				    (vector-ref b i)))
+		       (set! i (+ i 1)))
+		(eq? i l)
+		)
+	      0
+	      (vector-length a)
+	      )
+	     )
+	    (else #f)
+	    )
+      )
+    )
+  'equal?
+  )
+
+(_?_ (equal? '(a b c) '(a b c)) #t)
+(_?_ (equal? '(a b c) '(a b b)) #f)
+(_?_ (equal? #(1 2 3) #(1 2 3)) #t)
+(_?_ (equal? #(1 2 3) #(4 5 6)) #f)
+
+(define (_??_ a b)
+  (cond ((equal? a b)
+	 a
+	 )
+	(else
+	 (exit 1)
+	 )
+	)
+  )
+
+(define quasiquote
+  (macro (x)
+    (define (constant? exp)
+					; A constant value is either a pair starting with quote,
+					; or anything which is neither a pair nor a symbol
+
+      (cond ((pair? exp)
+	     (eq? (car exp) 'quote)
+	     )
+	    (else
+	     (not (symbol? exp))
+	     )
+	    )
+      )
+
+    (define (combine-skeletons left right exp)
+      (cond
+       ((and (constant? left) (constant? right)) 
+	(cond ((and (eqv? (eval left) (car exp))
+		    (eqv? (eval right) (cdr exp)))
+	       (list 'quote exp)
+	       )
+	      (else
+	       (list 'quote (cons (eval left) (eval right)))
+	       )
+	      )
+	)
+       ((null? right)
+	(list 'list left)
+	)
+       ((and (pair? right) (eq? (car right) 'list))
+	(cons 'list (cons left (cdr right)))
+	)
+       (else
+	(list 'cons left right)
+	)
+       )
+      )
+
+    (define (expand-quasiquote exp nesting)
+      (cond
+
+					; non cons -- constants
+					; themselves, others are
+					; quoted
+
+       ((not (pair? exp)) 
+	(cond ((constant? exp)
+	       exp
+	       )
+	      (else
+	       (list 'quote exp)
+	       )
+	      )
+	)
+
+					; check for an unquote exp and
+					; add the param unquoted
+
+       ((and (eq? (car exp) 'unquote) (= (length exp) 2))
+	(cond ((= nesting 0)
+	       (car (cdr exp))
+	       )
+	      (else
+	       (combine-skeletons ''unquote 
+				  (expand-quasiquote (cdr exp) (- nesting 1))
+				  exp))
+	      )
+	)
+
+					; nested quasi-quote --
+					; construct the right
+					; expression
+
+       ((and (eq? (car exp) 'quasiquote) (= (length exp) 2))
+	(combine-skeletons ''quasiquote 
+			   (expand-quasiquote (cdr exp) (+ nesting 1))
+			   exp))
+
+					; check for an
+					; unquote-splicing member,
+					; compute the expansion of the
+					; value and append the rest of
+					; the quasiquote result to it
+
+       ((and (pair? (car exp))
+	     (eq? (car (car exp)) 'unquote-splicing)
+	     (= (length (car exp)) 2))
+	(cond ((= nesting 0)
+	       (list 'append (car (cdr (car exp)))
+		     (expand-quasiquote (cdr exp) nesting))
+	       )
+	      (else
+	       (combine-skeletons (expand-quasiquote (car exp) (- nesting 1))
+				  (expand-quasiquote (cdr exp) nesting)
+				  exp))
+	      )
+	)
+
+					; for other lists, just glue
+					; the expansion of the first
+					; element to the expansion of
+					; the rest of the list
+
+       (else (combine-skeletons (expand-quasiquote (car exp) nesting)
+				(expand-quasiquote (cdr exp) nesting)
+				exp)
+	     )
+       )
+      )
+    (expand-quasiquote x 0)
+    )
+  )
+
+					; `q -> (quote q)
+					; `(q) -> (append (quote (q)))
+					; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2)))
+					; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3))
+
+
+(_??_ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) '(hello 3 1 2 3 (quasiquote foo)))
+
+					; define a set of local
+					; variables all at once and
+					; then evaluate a list of
+					; sexprs
+					;
+					; (let (var-defines) sexprs)
+					;
+					; where var-defines are either
+					;
+					; (name value)
+					;
+					; or
+					;
+					; (name)
+					;
+					; e.g.
+					;
+					; (let ((x 1) (y)) (set! y (+ x 1)) y)
+
+(define let
+  (macro (vars . exprs)
+	 (define (make-names vars)
+	   (cond ((not (null? vars))
+		  (cons (car (car vars))
+			(make-names (cdr vars))))
+		 (else ())
+		 )
+	   )
+
+					; the parameters to the lambda is a list
+					; of nils of the right length
+
+	 (define (make-vals vars)
+	   (cond ((not (null? vars))
+		  (cons (cond ((null? (cdr (car vars))) ())
+			      (else
+			       (car (cdr (car vars))))
+			      )
+			(make-vals (cdr vars))))
+		 (else ())
+		 )
+	   )
+					; prepend the set operations
+					; to the expressions
+
+					; build the lambda.
+
+	 `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars))
+	 )
+     )
+		   
+
+(_??_ (let ((x 1) (y)) (set! y 2) (+ x y)) 3)
+
+(define when (macro (test . l) `(cond (,test ,@l))))
+
+(_??_ (when #t (+ 1 2)) 3)
+(_??_ (when #f (+ 1 2)) #f)
+
+(define unless (macro (test . l) `(cond ((not ,test) ,@l))))
+
+(_??_ (unless #f (+ 2 3)) 5)
+(_??_ (unless #t (+ 2 3)) #f)
+
+(define (cdar l) (cdr (car l)))
+
+(_??_ (cdar '((1 2) (3 4))) '(2))
+
+(define (cddr l) (cdr (cdr l)))
+
+(_??_ (cddr '(1 2 3)) '(3))
+
+(define (caddr l) (car (cdr (cdr l))))
+
+(_??_ (caddr '(1 2 3 4)) 3)
+
+(define (reverse list)
+  (define (_r old new)
+    (if (null? old)
+	new
+	(_r (cdr old) (cons (car old) new))
+	)
+    )
+  (_r list ())
+  )
+
+(_??_ (reverse '(1 2 3)) '(3 2 1))
+
+(define make-list
+  (lambda (a . b)
+    (define (_m a x)
+      (if (zero? a)
+	  x
+	  (_m (- a 1) (cons b x))
+	  )
+      )
+    (if (null? b)
+	(set! b #f)
+	(set! b (car b))
+	)
+    (_m a '())
+    )
+  )
+    
+(_??_ (make-list 10 'a) '(a a a a a a a a a a))
+
+(_??_ (make-list 10) '(#f #f #f #f #f #f #f #f #f #f))
+
+(define for-each
+  (lambda (proc . lists)
+    (define (_f lists)
+      (cond ((null? (car lists)) #t)
+	    (else
+	     (apply proc (map car lists))
+	     (_f (map cdr lists))
+	     )
+	    )
+      )
+    (_f lists)
+    )
+  )
+
+(_??_ (let ((a 0))
+	(for-each (lambda (b) (set! a (+ a b))) '(1 2 3))
+	a
+	)
+      6)
+      
+(_??_ (call-with-current-continuation
+       (lambda (exit)
+	 (for-each (lambda (x)
+		     (if (negative? x)
+			 (exit x)))
+		   '(54 0 37 -3 245 19))
+	 #t))
+      -3)
+
+(define case
+  (macro (test . l)
+					; construct the body of the
+					; case, dealing with the
+					; lambda version ( => lambda)
+
+	 (define (_unarrow l)
+	   (cond ((null? l) l)
+		 ((eq? (car l) '=>) `(( ,(cadr l) __key__)))
+		 (else l))
+	   )
+
+					; Build the case elements, which is
+					; simply a list of cond clauses
+
+	 (define (_case l)
+
+	   (cond ((null? l) ())
+
+					; else case
+
+		 ((eq? (caar l) 'else)
+		  `((else ,@(_unarrow (cdr (car l))))))
+
+					; regular case
+		 
+		 (else
+		  (cons
+		   `((eqv? ,(caar l) __key__)
+		     ,@(_unarrow (cdr (car l))))
+		   (_case (cdr l)))
+		  )
+		 )
+	   )
+
+					; now construct the overall
+					; expression, using a lambda
+					; to hold the computed value
+					; of the test expression
+
+	 `((lambda (__key__)
+	     (cond ,@(_case l))) ,test)
+	 )
+  )
+
+(_??_ (case 1 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "one")
+(_??_ (case 2 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "two")
+(_??_ (case 3 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)) "three")) (12 "twelve") (else "else")) "three")
+(_??_ (case 4 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "else")
+(_??_ (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "twelve")
+
+(define do
+  (macro (vars test . cmds)
+    (define (_step v)
+      (if (null? v)
+	  '()
+	  (if (null? (cddr (car v)))
+	      (_step (cdr v))
+	      (cons `(set! ,(caar v) ,(caddr (car v)))
+		    (_step (cdr v))
+		    )
+	      )
+	  )
+      )
+    `(let ,(map (lambda (v) (list (car v) (cadr v))) vars)
+       (while (not ,(car test))
+	      ,@cmds
+	      ,@(_step vars)
+	      )
+       ,@(cdr test)
+       )
+    )
+  )
+
+(_??_ (do ((x 1 (+ x 1))
+	   (y 0)
+	   )
+	  ((= x 10) y)
+	(set! y (+ y x))
+	)
+      45)
+
+(_??_ (do ((vec (make-vector 5))
+	   (i 0 (+ i 1)))
+	  ((= i 5) vec)
+	(vector-set! vec i i)) #(0 1 2 3 4))