Added some simple versions of loop
loop/first loop/last loop/sum loop/product now added.
This commit is contained in:
		
							parent
							
								
									17d72f2cea
								
							
						
					
					
						commit
						80464ebe48
					
				
					 1 changed files with 30 additions and 0 deletions
				
			
		
							
								
								
									
										30
									
								
								goof.scm
									
										
									
									
									
								
							
							
						
						
									
										30
									
								
								goof.scm
									
										
									
									
									
								
							|  | @ -397,3 +397,33 @@ | ||||||
|      (loop loop-name (clauses ...) |      (loop loop-name (clauses ...) | ||||||
|        => '() |        => '() | ||||||
|        (cons (let () body ...) (loop-name)))))) |        (cons (let () body ...) (loop-name)))))) | ||||||
|  | 
 | ||||||
|  | (define-syntax loop/sum | ||||||
|  |   (syntax-rules () | ||||||
|  |     ((_ (clauses ...) body ...) | ||||||
|  |      (loop (clauses ... (acc (summing (let () body ...)))) => acc)))) | ||||||
|  | 
 | ||||||
|  | (define-syntax loop/product | ||||||
|  |   (syntax-rules () | ||||||
|  |     ((_ (clauses ...) body ...) | ||||||
|  |      (loop (clauses ... (acc (multiplying (let () body ...)))) => acc)))) | ||||||
|  | 
 | ||||||
|  | (define sentinel (list 'unique)) | ||||||
|  | 
 | ||||||
|  | (define-syntax loop/first | ||||||
|  |   (syntax-rules () | ||||||
|  |     ((_ (clauses ...) body ...) | ||||||
|  |      (loop loop-name ((acc (folding sentinel)) clauses ... :break (not (eq? sentinel acc))) | ||||||
|  |            => (if (eq? sentinel acc) #f acc) | ||||||
|  |            (let ((result (let () body ...))) | ||||||
|  |              (loop-name (=> acc result))))))) | ||||||
|  | 
 | ||||||
|  | (define-syntax loop/last | ||||||
|  |   (syntax-rules () | ||||||
|  |     ((_ (clauses ...) body ...) | ||||||
|  |      (loop loop-name ((acc (folding sentinel)) clauses ...) => (if (eq? sentinel acc) #f acc) | ||||||
|  |            (let ((result (let () body ...))) | ||||||
|  |              (loop-name (=> acc result))))))) | ||||||
|  |             | ||||||
|  | 
 | ||||||
|  | 
 | ||||||
|  |  | ||||||
		Loading…
	
	Add table
		Add a link
		
	
		Reference in a new issue
	
	 Linus
						Linus