From 455f839be6ce83f0131de3cc6d3449e9e6b85ca3 Mon Sep 17 00:00:00 2001 From: Tim Vaughan Date: Mon, 26 Jun 2017 09:08:59 +1200 Subject: [PATCH] Library functioning using new quasiquote. New macro quasiquote is much slower than previous primitive implementation, but more elegant. Syntactic analysis should mitigate some of this problem. Currently shares limitation of primitive implementation in that quasiquotations can't be reliably nested. --- src/scheme-library.scm | 128 ++++++++++++++++++++++++---------------- src/scheme.4th | 5 +- src/testing-library.scm | 50 ---------------- 3 files changed, 78 insertions(+), 105 deletions(-) delete mode 100644 src/testing-library.scm diff --git a/src/scheme-library.scm b/src/scheme-library.scm index ec5c08e..8740e15 100644 --- a/src/scheme-library.scm +++ b/src/scheme-library.scm @@ -2,15 +2,78 @@ ;; Standard Library Procedures and Macros ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; MISC ESSENTIAL PROCEDURES + +(define list + (lambda args args)) + +(define map + (lambda (proc l) + (if (null? l) + '() + (cons (proc (car l)) (map proc (cdr l)))))) + +(define join-lists + (lambda (l1 l2) + (if (null? l1) + l2 + (cons (car l1) (join-lists (cdr l1) l2))))) + +; Append an arbitrary number of lists together +(define append + (lambda lists + (if (null? lists) + () + (if (null? (cdr lists)) + (car lists) + (join-lists (car lists) (apply append (cdr lists))))))) + + ;; DERIVED FORMS -;; define (procedural syntax) +;; define (define-macro (define args . body) (if (pair? args) - `(define ,(car args) (lambda ,(cdr args) ,@body)) + (list 'define (car args) (join-lists (list 'lambda (cdr args)) body)) 'no-match)) +;; not + +(define-macro (not x) + (list 'if x #f #t)) + +;; let + +(define-macro (let args . body) + (join-lists + (list (join-lists (list 'lambda (map (lambda (x) (car x)) args)) body)) + (map (lambda (x) (car (cdr x))) args))) + +;; quasiquote/unquote (one nesting level only) + +((lambda () + (define (qqhelper l) + (if (null? l) + l + (let ((head (car l)) + (tail (cdr l))) + + (if (pair? head) + (if (eq? (car head) 'unquote) + (list 'cons (car (cdr head)) (qqhelper tail)) + (if (eq? (car head) 'unquote-splicing) + (list 'join-lists (car (cdr head)) (qqhelper tail)) + (list 'cons (list 'quasiquote head) (qqhelper tail)))) + (if (symbol? head) + (list 'cons (list 'quote head) (qqhelper tail)) + (list 'cons head (qqhelper tail))))))) + + (define-macro (quasiquote arg) + (if (not (pair? arg)) + (list 'quote arg) + (qqhelper arg))))) + ;; begin (define-macro (begin . sequence) @@ -32,20 +95,6 @@ (define-macro (cdddr l) `(cdr (cdr (cdr ,l)))) (define-macro (cadddr l) `(car (cdr (cdr (cdr ,l))))) - -;; Methods used in remaining macro definitions: - -(define (map proc l) - (if (null? l) - '() - (cons (proc (car l)) (map proc (cdr l))))) - -;; let - -(define-macro (let args . body) - `((lambda ,(map (lambda (x) (car x)) args) - ,@body) ,@(map (lambda (x) (cadr x)) args))) - ;; let* (define-macro (let* args . body) @@ -105,31 +154,24 @@ (define-macro (and . expressions) (if (null? expressions) #t - (expand-and-expressions expressions))) - )) + (expand-and-expressions expressions))))) ;; or ((lambda () (define (expand-or-expressions expressions) - (if (null? expressions) - #f - (let ((first (car expressions)) - (rest (cdr expressions)) - (val (gensym))) - `(let ((,val ,first)) - (if ,val - ,val - ,(expand-or-expressions rest)))))) + (let ((first (car expressions)) + (rest (cdr expressions))) + (if (null? rest) + first + `(if ,first + #t + ,(expand-or-expressions rest))))) (define-macro (or . expressions) - (expand-or-expressions expressions)) - )) - -;; not - -(define-macro (not x) - `(if ,x #f #t)) + (if (null? expressions) + #f + (expand-or-expressions expressions))))) ;; FUNCTIONAL PROGRAMMING @@ -322,9 +364,6 @@ ;; LISTS -; List creation -(define (list . args) args) - ; Return number of items in list (define (length l) (define (iter a count) @@ -333,20 +372,6 @@ (iter (cdr a) (fix:+ count 1)))) (iter l 0)) -; Join two lists together -(define (join l1 l2) - (if (null? l1) - l2 - (cons (car l1) (join (cdr l1) l2)))) - -; Append an arbitrary number of lists together -(define (append . lists) - (if (null? lists) - () - (if (null? (cdr lists)) - (car lists) - (join (car lists) (apply append (cdr lists)))))) - ; Reverse the contents of a list (define (reverse l) (if (null? l) @@ -382,7 +407,6 @@ (fix:+ n (sum-recurse (fix:- n 1))))) - ;; MISC (define (license) diff --git a/src/scheme.4th b/src/scheme.4th index 72d2c9d..abd214e 100644 --- a/src/scheme.4th +++ b/src/scheme.4th @@ -1987,8 +1987,7 @@ variable gc-stack-depth include scheme-primitives.4th - s" testing-library.scm" load 2drop - \ s" scheme-library.scm" load 2drop + s" scheme-library.scm" load 2drop \ }}} @@ -2021,7 +2020,7 @@ variable gc-stack-depth enable-gc \ Display welcome message - \ welcome-symbol nil cons global-env obj@ eval 2drop + welcome-symbol nil cons global-env obj@ eval 2drop begin ['] repl-body catch diff --git a/src/testing-library.scm b/src/testing-library.scm deleted file mode 100644 index fa4fb08..0000000 --- a/src/testing-library.scm +++ /dev/null @@ -1,50 +0,0 @@ -(define list (lambda args args)) - -(define join-lists - (lambda (l1 l2) - (if (null? l1) - l2 - (cons (car l1) (join-lists (cdr l1) l2))))) - -(define-macro (cadr x) (list 'car (list 'cdr x))) - -(define-macro (define args . body) - (if (pair? args) - (list 'define (car args) (join-lists (list 'lambda (cdr args)) body)) - 'no-match)) - -(define (map proc l) - (if (null? l) - '() - (cons (proc (car l)) (map proc (cdr l))))) - - -(define-macro (not x) - (list 'if x #f #t)) - -(define-macro (let args . body) - (join-lists - (list (join-lists (list 'lambda (map (lambda (x) (car x)) args)) body)) - (map (lambda (x) (cadr x)) args))) - -((lambda () - (define (qqhelper l) - (if (null? l) - l - (let ((head (car l)) - (tail (cdr l))) - - (if (pair? head) - (if (eq? (car head) 'unquote) - (list 'cons (cadr head) (qqhelper tail)) - (if (eq? (car head) 'unquote-splicing) - (list 'join-lists (cadr head) (qqhelper tail)) - (list 'cons (list 'quasiquote head) (qqhelper tail)))) - (if (symbol? head) - (list 'cons (list 'quote head) (qqhelper tail)) - (list 'cons head (qqhelper tail))))))) - - (define-macro (quasiquote arg) - (if (not (pair? arg)) - (list 'quote arg) - (qqhelper arg))))) -- 2.20.1