Skip to content

Commit

Permalink
Merge pull request #414 from yamacir-kit/cleanup
Browse files Browse the repository at this point in the history
  • Loading branch information
@yamacir-kit
yamacir-kit authored Oct 11, 2022
2 parents ab9adc0 + d2005b9 commit d348b91
Show file tree
Hide file tree
Showing 54 changed files with 664 additions and 479 deletions.
11 changes: 10 additions & 1 deletion CMakeLists.txt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,11 +19,18 @@ set(CMAKE_CXX_STANDARD_REQUIRED ON)
set(CMAKE_POSITION_INDEPENDENT_CODE ON)
set(CMAKE_VERBOSE_MAKEFILE OFF)

string(CONCAT UNSTABLE_OPTIMIZATION_OPTIONS # JOIN available if VERSION > 3.12
# "-flto " # This optimization causes a SEGV when compiling with Clang 10.
# "-fmerge-all-constants " # This optimization is very effective in reducing binary size, but non-standard to the C++ standard.
# "-march=native " # This optimization causes "Illegal instruction" error (is Valgrind's bug) on CI.
# "-mtune=native "
)

set(CMAKE_CXX_FLAGS "-Wall -Wextra -Wpedantic -pipe")
set(CMAKE_CXX_FLAGS_DEBUG "-Og -g")
set(CMAKE_CXX_FLAGS_MINSIZEREL "-Os -DNDEBUG")
set(CMAKE_CXX_FLAGS_RELWITHDEBINFO "-O2 -g -DNDEBUG")
set(CMAKE_CXX_FLAGS_RELEASE "-O3 -DNDEBUG") # NOTE: -march=native causes "Illegal instruction" error (is Valgrind's bug) on CI.
set(CMAKE_CXX_FLAGS_RELEASE "-O3 -DNDEBUG ${UNSTABLE_OPTIMIZATION_OPTIONS}")

set(CMAKE_LIBRARY_OUTPUT_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/${CMAKE_INSTALL_LIBDIR})
set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/${CMAKE_INSTALL_BINDIR})
Expand Down Expand Up @@ -171,13 +178,15 @@ check(internal-definition)
check(let-syntax)
check(letrec-syntax)
check(numerical-operations)
check(parameterize)
check(r4rs)
check(r4rs-appendix)
check(r5rs)
check(r7rs)
check(sicp-1)
check(srfi-8)
check(transformer)
check(with-exception-handler)

file(GLOB ${PROJECT_NAME}_TEST_CXX ${CMAKE_CURRENT_SOURCE_DIR}/test/*.cpp)
foreach(FILEPATH IN LISTS ${PROJECT_NAME}_TEST_CXX)
Expand Down
6 changes: 3 additions & 3 deletions README.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -105,9 +105,9 @@ sudo rm -rf /usr/local/share/meevax

| Target Name | Description
|:-------------------|:--
| `all` (default) | Build shared-library `libmeevax.0.4.232.so` and executable `meevax`.
| `all` (default) | Build shared-library `libmeevax.0.4.278.so` and executable `meevax`.
| `test` | Test executable `meevax`.
| `package` | Generate debian package `meevax_0.4.232_amd64.deb`.
| `package` | Generate debian package `meevax_0.4.278_amd64.deb`.
| `install` | Copy files into `/usr/local` __(1)__.
| `install.deb` | `all` + `package` + `sudo apt install <meevax>.deb`
| `safe-install.deb` | `all` + `test` + `package` + `sudo apt install <meevax>.deb`
Expand All @@ -122,7 +122,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's
## Usage

```
Meevax Lisp System, version 0.4.232
Meevax Lisp System, version 0.4.278
Usage: meevax [OPTION...] [FILE...]
Expand Down
2 changes: 1 addition & 1 deletion VERSION
View file
Original file line number Diff line number Diff line change
@@ -1 +1 @@
0.4.232
0.4.278
10 changes: 7 additions & 3 deletions basis/r4rs-essential.ss
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,9 @@
(import (meevax character)
(meevax control)
(meevax environment)
(meevax equivalence)
(rename (meevax comparator)
(identity=? eq?)
(normally=? eqv?))
(meevax foreign-function)
(meevax list)
(meevax number)
Expand All @@ -11,8 +13,7 @@
(meevax read)
(meevax string)
(meevax symbol)
(rename (meevax syntax)
(call-with-current-continuation! call-with-current-continuation))
(meevax syntax)
(meevax vector)
(meevax write)
(srfi 211 explicit-renaming))
Expand Down Expand Up @@ -541,6 +542,9 @@
(begin (apply map f x xs)
(if #f #f))))

(define (call-with-current-continuation f)
(call-with-current-continuation! f))

(define (call-with-input-file path f) ; r7rs incompatible (values unsupported)
(define (call-with-input-port port f)
(let ((result (f port)))
Expand Down
35 changes: 22 additions & 13 deletions basis/r5rs.ss
View file
Original file line number Diff line number Diff line change
@@ -1,39 +1,48 @@
(define-library (scheme r5rs continuation)
(import (meevax context)
(only (meevax syntax) define-syntax)
(rename (scheme r4rs) (call-with-current-continuation r4rs:call/cc)))
(only (meevax dynamic-environment) load-auxiliary store-auxiliary)
(only (meevax syntax) define-syntax call-with-current-continuation!)
(except (scheme r4rs) call-with-current-continuation))

(export call-with-current-continuation dynamic-wind exit)

(begin (define %current-dynamic-extents '()) ; https://www.cs.hmc.edu/~fleck/envision/scheme48/meeting/node7.html
; https://www.cs.hmc.edu/~fleck/envision/scheme48/meeting/node7.html

(begin (define (current-dynamic-extents)
(load-auxiliary 0))

(define (install-dynamic-extents! extents)
(store-auxiliary 0 extents))

(define (dynamic-wind before thunk after)
(before)
(set! %current-dynamic-extents (cons (cons before after) %current-dynamic-extents))
(install-dynamic-extents! (cons (cons before after)
(current-dynamic-extents)))
((lambda (result) ; TODO let-values
(set! %current-dynamic-extents (cdr %current-dynamic-extents))
(install-dynamic-extents! (cdr (current-dynamic-extents)))
(after)
result) ; TODO (apply values result)
(thunk)))

(define (call-with-current-continuation procedure)
(define (windup! from to)
(set! %current-dynamic-extents from)
(install-dynamic-extents! from)
(cond ((eq? from to))
((null? from) (windup! from (cdr to)) ((caar to)))
((null? to) ((cdar from)) (windup! (cdr from) to))
(else ((cdar from)) (windup! (cdr from) (cdr to)) ((caar to))))
(set! %current-dynamic-extents to))
(let ((current-dynamic-extents %current-dynamic-extents))
(r4rs:call/cc (lambda (k1)
(procedure (lambda (k2)
(windup! %current-dynamic-extents current-dynamic-extents)
(k1 k2)))))))
(install-dynamic-extents! to))
(let ((dynamic-extents (current-dynamic-extents)))
(call-with-current-continuation!
(lambda (continue)
(procedure (lambda (x)
(windup! (current-dynamic-extents) dynamic-extents)
(continue x)))))))

(define (exit . normally?)
(for-each (lambda (before/after)
((cdr before/after)))
%current-dynamic-extents)
(current-dynamic-extents))
(apply emergency-exit normally?))))

(define-library (scheme r5rs)
Expand Down
27 changes: 11 additions & 16 deletions basis/r7rs.ss
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,21 +2,11 @@
(import (only (meevax error) error? read-error? file-error?)
(only (meevax number) exact-integer?)
(only (meevax vector) vector-append vector-copy vector-copy! string->vector)
(only (meevax port) binary-port?
textual-port?
port?
input-port-open?
output-port-open?
standard-input-port
standard-output-port
standard-error-port
eof-object
get-ready?
get-char
get-char!
put-char
put-string
%flush-output-port)
(only (meevax port)
binary-port? textual-port? port? input-port-open? output-port-open?
standard-input-port standard-output-port standard-error-port
eof-object get-ready? get-char get-char! put-char put-string
%flush-output-port)
(only (meevax string) string-copy! vector->string)
(only (meevax version) features)
(scheme r5rs)
Expand Down Expand Up @@ -61,7 +51,7 @@
syntax-rules
_
...
; syntax-error
syntax-error
define
; define-values
define-syntax
Expand Down Expand Up @@ -286,6 +276,11 @@
(cadr form))
,@(cddr form)))))

(define-syntax syntax-error
(er-macro-transformer
(lambda (form rename compare)
(apply error (cdr form)))))

(define (floor-quotient x y)
(floor (/ x y)))

Expand Down
4 changes: 3 additions & 1 deletion basis/srfi-211.ss
View file
Original file line number Diff line number Diff line change
Expand Up @@ -13,7 +13,9 @@
(export sc-macro-transformer rsc-macro-transformer make-syntactic-closure identifier?))

(define-library (srfi 211 explicit-renaming)
(import (meevax equivalence)
(import (rename (meevax comparator)
(identity=? eq?)
(normally=? eqv?))
(meevax list)
(meevax macro)
(meevax pair)
Expand Down
50 changes: 29 additions & 21 deletions basis/srfi-34.ss
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,37 +19,48 @@
; IN THE SOFTWARE.

(define-library (srfi 34)
(import (only (meevax error) throw)
(import (only (meevax dynamic-environment) load-auxiliary store-auxiliary)
(only (meevax error) throw)
(scheme r5rs))

(export with-exception-handler raise raise-continuable guard)

(begin (define %current-exception-handlers (list throw))
(begin (define (current-exception-handlers)
(load-auxiliary 2))

(define (%with-exception-handlers new-handlers thunk)
(let ((old-handlers %current-exception-handlers))
(define (install-exception-handlers! handlers)
(store-auxiliary 2 handlers))

(define (with-exception-handlers new-handlers thunk)
(let ((old-handlers (current-exception-handlers)))
(dynamic-wind
(lambda () (set! %current-exception-handlers new-handlers)) ; install
(lambda () (install-exception-handlers! new-handlers)) ; install
thunk
(lambda () (set! %current-exception-handlers old-handlers))))) ; uninstall
(lambda () (install-exception-handlers! old-handlers))))) ; uninstall

(define (with-exception-handler handler thunk)
(%with-exception-handlers (cons handler %current-exception-handlers) thunk))
(with-exception-handlers (cons handler (current-exception-handlers)) thunk))

(define (raise x)
(let ((inner (car %current-exception-handlers))
(outer (cdr %current-exception-handlers)))
(%with-exception-handlers outer
(let ((inner (car (current-exception-handlers)))
(outer (cdr (current-exception-handlers))))
(with-exception-handlers outer
(lambda ()
(inner x)
(error "If the handler returns, a secondary exception is raised in the same dynamic environment as the handler")))))
(if (procedure? inner)
(inner x)
(throw x))
(throw x)))))

(define (raise-continuable x)
(let ((inner (car %current-exception-handlers))
(outer (cdr %current-exception-handlers)))
(%with-exception-handlers outer
(lambda ()
(inner x)))))
(let ((inner (car (current-exception-handlers)))
(outer (cdr (current-exception-handlers))))
(with-exception-handlers outer
(lambda ()
(if (procedure? inner)
(inner x)
(throw x))))))

(declare-raiser raise)

(define-syntax guard
(syntax-rules ()
Expand Down Expand Up @@ -107,7 +118,4 @@
clause1 clause2 ...)
(if test
(begin result1 result2 ...)
(guard-aux reraise clause1 clause2 ...)))))

)
)
(guard-aux reraise clause1 clause2 ...)))))))
77 changes: 32 additions & 45 deletions basis/srfi-39.ss
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,61 +19,48 @@
; SOFTWARE.

(define-library (srfi 39)
(import (scheme r5rs)
(import (only (meevax dynamic-environment) load-auxiliary store-auxiliary)
(scheme r5rs)
(srfi 211 explicit-renaming))

(export make-parameter parameterize)

(begin (define make-parameter
(lambda (init . conv)
(let ((converter (if (null? conv)
(lambda (x) x)
(car conv))))
(let ((global-cell
(cons #f (converter init))))
(letrec ((parameter
(lambda new-val
(let ((cell (dynamic-lookup parameter global-cell)))
(cond ((null? new-val)
(cdr cell))
((null? (cdr new-val))
(set-cdr! cell (converter (car new-val))))
(else ; this case is needed for parameterize
(converter (car new-val))))))))
(set-car! global-cell parameter)
parameter)))))
(begin (define (current-dynamic-bindings)
(load-auxiliary 1))

(define dynamic-bind
(lambda (parameters values body)
(let* ((old-local
(dynamic-env-local-get))
(new-cells
(map (lambda (parameter value)
(cons parameter (parameter value #f)))
parameters
values))
(new-local
(append new-cells old-local)))
(dynamic-wind
(lambda () (dynamic-env-local-set! new-local))
body
(lambda () (dynamic-env-local-set! old-local))))))
(define (install-dynamic-bindings! bindings)
(store-auxiliary 1 bindings))

(define dynamic-lookup
(lambda (parameter global-cell)
(or (assq parameter (dynamic-env-local-get))
global-cell)))
(define (make-parameter init . converter)
(let* ((convert (if (null? converter)
(lambda (x) x)
(car converter)))
(default (cons #f (convert init))))
(letrec ((parameter
(lambda value
(let ((cell (or (assq parameter (current-dynamic-bindings)) default)))
(cond ((null? value)
(cdr cell))
((null? (cdr value))
(set-cdr! cell (convert (car value))))
(else ; Apply converter to value
(convert (car value))))))))
(set-car! default parameter)
parameter)))

(define dynamic-env-local '())

(define (dynamic-env-local-get) dynamic-env-local)

(define (dynamic-env-local-set! new-env)
(set! dynamic-env-local new-env))
(define (dynamic-bind parameters values body)
(let* ((outer (current-dynamic-bindings))
(inner (map (lambda (parameter value)
(cons parameter (parameter value 'apply-converter-to-value)))
parameters
values)))
(dynamic-wind (lambda () (install-dynamic-bindings! (append inner outer)))
body
(lambda () (install-dynamic-bindings! outer)))))

(define-syntax parameterize
(er-macro-transformer
(lambda (form rename compare)
`(,(rename 'dynamic-bind) (,(rename 'list) ,@(map car (cadr form)))
`(,(rename 'dynamic-bind) (,(rename 'list) ,@(map car (cadr form)))
(,(rename 'list) ,@(map cadr (cadr form)))
(,(rename 'lambda) () ,@(cddr form))))))))
2 changes: 0 additions & 2 deletions include/meevax/kernel/character.hpp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -17,8 +17,6 @@
#ifndef INCLUDED_MEEVAX_KERNEL_CHARACTER_HPP
#define INCLUDED_MEEVAX_KERNEL_CHARACTER_HPP

#include <iostream>

#include <meevax/kernel/pair.hpp>

namespace meevax
Expand Down
Loading

0 comments on commit d348b91

Please sign in to comment.