diff --git a/ChangeLog.markdown b/ChangeLog.markdown --- a/ChangeLog.markdown +++ b/ChangeLog.markdown @@ -1,3 +1,31 @@ +v3.15 +-------- + +The big change for this release is an online [User Manual](http://justinethier.github.io/husk-scheme/manual/index.html) based on the R7RS, that documents Husk's Scheme and Haskell APIs, and explains the Scheme language as implemented by Husk. This is going to be a work-in-progress but is mostly complete, and can be used immediately as a reference. + +In addition, many smaller fixes and enhancements are included: + +- Improved library support so that examples no longer require running in a special mode. +- Added missing functions to `(scheme base)`. +- Added support for the `(scheme case-lambda)` and `(scheme r5rs)` libraries. +- Added libraries for SRFI 1, 2, and 69 so that these features are available via `import`. + - For example: `(import (srfi 1))`. +- Added `exact-integer-sqrt` from R7RS, using the Chibi scheme reference implementation. +- Added `let-values` and `let*-values` from R7RS. +- Added the following I/O functions: + - `binary-port?` + - `close-port` + - `input-port-open?` + - `open-binary-input-file` + - `open-binary-output-file` + - `output-port-open?` + - `read-bytevector` + - `textual-port?` + - `u8-ready?` + - `write-bytevector` +- Allow character and string comparison predicates (such as `string=?` and `char=?`) to support more than two arguments. +- Fixed `cond-expand` to support `and` / `or` clauses. +- Renamed `char-upper` and `char-lower` to `char-upcase` and `char-downcase` to match the Scheme specs. v3.14 -------- diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,21 +1,23 @@ [husk-scheme](http://justinethier.github.com/husk-scheme) -husk is a dialect of Scheme written in Haskell that implements a superset of the [R5RS standard](http://www.schemers.org/Documents/Standards/R5RS/HTML/). Advanced R5RS features are provided including continuations, hygienic macros, and a full numeric tower. +Husk is a dialect of Scheme written in Haskell that implements a superset of the [R5RS standard](http://www.schemers.org/Documents/Standards/R5RS/HTML/) and a large portion of the R7RS-small language. Advanced features are provided including continuations, hygienic macros, libraries, and a full numeric tower. -husk may be used as either a stand-alone interpreter or as an extension language within a larger Haskell application. By closely following the R5RS standard, the intent is to develop a Scheme that is as compatible as possible with other R5RS Schemes. husk is mature enough for use in production applications, however it is not optimized for performance-critical applications. +Husk may be used as either a stand-alone interpreter or as an extension language within a larger Haskell application. By closely following the R5RS standard, the intent is to develop a Scheme that is as compatible as possible with other R5RS Schemes. Husk is mature enough for use in production applications, however it is not optimized for performance-critical applications. Scheme is one of two main dialects of Lisp. Scheme follows a minimalist design philosophy: the core language consists of a small number of fundamental forms which may be used to implement other built-in forms. Scheme is an excellent language for writing small, elegant programs, and may also be used to write scripts or embed scripting functionality within a larger application. +More information is available on the [husk website](http://justinethier.github.com/husk-scheme). + Installation ------------ -The [Glasgow Haskell Compiler](http://www.haskell.org/ghc/) (GHC) is required to build, install, and run husk. All recent versions of GHC are supported, including 7.0, 7.2, 7.4, and 7.6. The easiest way to get GHC is via the [Haskell Platform](http://hackage.haskell.org/platform/). +The [Glasgow Haskell Compiler](http://www.haskell.org/ghc/) (GHC) is required to build, install, and run Husk. All recent versions of GHC are supported, including 7.0, 7.2, 7.4, and 7.6. The easiest way to get GHC is via the [Haskell Platform](http://hackage.haskell.org/platform/). -husk may be installed using [cabal](http://www.haskell.org/cabal/): +Husk may be installed using [cabal](http://www.haskell.org/cabal/): cabal update cabal install husk-scheme -Before running husk you may also need to add the cabal executable directory to your path. On Linux this is `~/.cabal/bin`. Now you are ready to start up the interpreter: +Before running Husk you may also need to add the cabal executable directory to your path. On Linux this is `~/.cabal/bin`. Now you are ready to start up the interpreter: justin@my-pc$ huski _ _ __ _ @@ -34,15 +36,17 @@ huski> (hello) world -husk has been tested on Windows, Linux, and FreeBSD. +Husk has been tested on Windows, Linux, and FreeBSD. -More information is available on the [husk website](http://justinethier.github.com/husk-scheme). +Documentation +------------- +The online [user manual](http://justinethier.github.io/husk-scheme/manual/index.html) provides an overview of the Scheme language as implemented by Husk, instructions for using the Haskell API, an alphabetical index of Scheme functions, and more. License ------- Copyright (C) 2010 [Justin Ethier](http://github.com/justinethier) -husk scheme is available under the [MIT license](http://www.opensource.org/licenses/mit-license.php). +Husk scheme is available under the [MIT license](http://www.opensource.org/licenses/mit-license.php). The interpreter is based on code from the book [Write Yourself a Scheme in 48 Hours](http://en.wikibooks.org/wiki/Write_Yourself_a_Scheme_in_48_Hours) written by Jonathan Tang and hosted / maintained by Wikibooks. diff --git a/hs-src/Language/Scheme/Core.hs b/hs-src/Language/Scheme/Core.hs --- a/hs-src/Language/Scheme/Core.hs +++ b/hs-src/Language/Scheme/Core.hs @@ -72,7 +72,7 @@ -- |husk version number version :: String -version = "3.14" +version = "3.15" -- |A utility function to display the husk console banner showBanner :: IO () @@ -1063,11 +1063,15 @@ _ <- evalString metaEnv $ "(load \"" ++ (escapeBackslashes metalib) ++ "\")" -- Load meta-env so we can find it later _ <- evalLisp' env $ List [Atom "define", Atom "*meta-env*", LispEnv metaEnv] - -- Load (r5rs base) - _ <- evalString metaEnv - "(add-module! '(scheme r5rs) (make-module #f (interaction-environment) '()))" + -- Load base primitives + _ <- evalLisp' metaEnv $ List [Atom "add-module!", List [Atom "quote", List [Atom "scheme"]], List [Atom "make-module", Bool False, LispEnv env {-baseEnv-}, List [Atom "quote", List []]]] +-- _ <- evalString metaEnv +-- "(add-module! '(scheme r5rs) (make-module #f (interaction-environment) '()))" timeEnv <- liftIO $ r7rsTimeEnv _ <- evalLisp' metaEnv $ List [Atom "add-module!", List [Atom "quote", List [Atom "scheme", Atom "time", Atom "posix"]], List [Atom "make-module", Bool False, LispEnv timeEnv, List [Atom "quote", List []]]] + + processContextEnv <- liftIO $ r7rsProcessContextEnv + _ <- evalLisp' metaEnv $ List [Atom "add-module!", List [Atom "quote", List [Atom "scheme", Atom "process-context"]], List [Atom "make-module", Bool False, LispEnv processContextEnv, List [Atom "quote", List []]]] _ <- evalLisp' metaEnv $ List [ Atom "define", Atom "library-exists?", @@ -1078,6 +1082,9 @@ return env -- |Load the standard r7rs environment, including libraries +-- +-- Note that the only difference between this and the r5rs equivalent is that +-- slightly less Scheme code is loaded initially. r7rsEnv :: IO Env r7rsEnv = do env <- r7rsEnv' @@ -1086,8 +1093,6 @@ return env -- |Load the standard r7rs environment --- --- TODO: This is just a stub, do not try using it yet! -- r7rsEnv' :: IO Env r7rsEnv' = do diff --git a/hs-src/Language/Scheme/Environments.hs b/hs-src/Language/Scheme/Environments.hs --- a/hs-src/Language/Scheme/Environments.hs +++ b/hs-src/Language/Scheme/Environments.hs @@ -28,14 +28,22 @@ {- I/O primitives Primitive functions that execute within the IO monad -} ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)] -ioPrimitives = [("open-input-file", makePort ReadMode), - ("open-output-file", makePort WriteMode), +ioPrimitives = [("open-input-file", makePort openFile ReadMode), + ("open-binary-input-file", makePort openBinaryFile ReadMode), + ("open-output-file", makePort openFile WriteMode), + ("open-binary-output-file", makePort openBinaryFile WriteMode), + ("close-port", closePort), ("close-input-port", closePort), ("close-output-port", closePort), ("flush-output-port", flushOutputPort), + ("textual-port?", isTextPort), + ("binary-port?", isBinaryPort), + ("input-port-open?", isInputPortOpen), + ("output-port-open?", isOutputPortOpen), ("input-port?", isInputPort), ("output-port?", isOutputPort), ("char-ready?", isCharReady), + ("u8-ready?", isCharReady), -- Good enough? -- The following optional procedures are NOT implemented: -- @@ -52,9 +60,11 @@ ("read", readProc True), ("read-line", readProc False), ("read-char", readCharProc hGetChar), + ("read-bytevector", readByteVector), ("peek-char", readCharProc hLookAhead), ("write", writeProc (\ port obj -> hPrint port obj)), ("write-char", writeCharProc), + ("write-bytevector", writeByteVector), ("display", writeProc (\ port obj -> do case obj of String str -> hPutStr port str @@ -221,8 +231,8 @@ ("char-lower-case?", charPredicate Data.Char.isLower), ("char->integer", char2Int), ("integer->char", int2Char), - ("char-upper", charUpper), - ("char-lower", charLower), + ("char-upcase", charUpper), + ("char-downcase", charLower), ("digit-value", charDigitValue), ("procedure?", isProcedure), diff --git a/hs-src/Language/Scheme/Macro.hs b/hs-src/Language/Scheme/Macro.hs --- a/hs-src/Language/Scheme/Macro.hs +++ b/hs-src/Language/Scheme/Macro.hs @@ -1230,12 +1230,9 @@ return $ appendNil (Matches.getData var ellipsisIndex) isImproperPattern isImproperInput - else if length v > 0 - then return var -- Just return the elements directly, so all can be appended - else return $ Nil "" -- A 0 match case, flag it to calling code + else return var -- no ellipsis, just return elements directly, so all can be appended _ -> if ellipsisLevel > 0 - then -- List req'd for 0-or-n match - throwError $ Default "Unexpected error processing data in transformRule" + then return var -- Let this pass, in case var is not involved in o-to-n match else return var else do -- Rename each encountered symbol, but the trick is that we want to give diff --git a/hs-src/Language/Scheme/Primitives.hs b/hs-src/Language/Scheme/Primitives.hs --- a/hs-src/Language/Scheme/Primitives.hs +++ b/hs-src/Language/Scheme/Primitives.hs @@ -117,13 +117,19 @@ , flushOutputPort , currentOutputPort , currentInputPort + , isTextPort + , isBinaryPort , isOutputPort , isInputPort + , isInputPortOpen + , isOutputPortOpen , isCharReady , readProc , readCharProc + , readByteVector , writeProc , writeCharProc + , writeByteVector , readContents , load , readAll @@ -180,11 +186,15 @@ -- -- Returns: Port -- -makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal -makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode -makePort mode [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= makePort mode -makePort _ [] = throwError $ NumArgs (Just 1) [] -makePort _ args@(_ : _) = throwError $ NumArgs (Just 1) args +makePort + :: (FilePath -> IOMode -> IO Handle) + -> IOMode + -> [LispVal] + -> IOThrowsError LispVal +makePort openFnc mode [String filename] = liftM Port $ liftIO $ openFnc filename mode +makePort fnc mode [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= makePort fnc mode +makePort _ _ [] = throwError $ NumArgs (Just 1) [] +makePort _ _ args@(_ : _) = throwError $ NumArgs (Just 1) args -- |Close the given port -- @@ -227,6 +237,40 @@ flushOutputPort [Port port] = liftIO $ hFlush port >> (return $ Bool True) flushOutputPort _ = return $ Bool False +isTextPort :: [LispVal] -> IOThrowsError LispVal +isTextPort [Port port] = do + val <- liftIO $ isTextPort' port + return $ Bool val +isTextPort _ = return $ Bool False + +isBinaryPort :: [LispVal] -> IOThrowsError LispVal +isBinaryPort [Port port] = do + val <- liftIO $ isTextPort' port + return $ Bool $ not val +isBinaryPort _ = return $ Bool False + +-- | Determine if a file handle is in text mode +isTextPort' port = do + textEncoding <- hGetEncoding port + case textEncoding of + Nothing -> return False + _ -> return True + + +isInputPortOpen :: [LispVal] -> IOThrowsError LispVal +isInputPortOpen [Port port] = do + r <- liftIO $ hIsReadable port + o <- liftIO $ hIsOpen port + return $ Bool $ r && o +isInputPortOpen _ = return $ Bool False + +isOutputPortOpen :: [LispVal] -> IOThrowsError LispVal +isOutputPortOpen [Port port] = do + w <- liftIO $ hIsWritable port + o <- liftIO $ hIsOpen port + return $ Bool $ w && o +isOutputPortOpen _ = return $ Bool False + -- |Determine if the given objects is an input port -- -- LispVal Arguments: @@ -314,6 +358,21 @@ return $ Char inpChr readCharProc _ args@(_ : _) = throwError $ BadSpecialForm "" $ List args +readByteVector :: [LispVal] -> IOThrowsError LispVal +readByteVector [Number n, Port port] = do + input <- liftIO $ try' (liftIO $ BS.hGet port $ fromInteger n) + case input of + Left e -> if isEOFError e + then return $ EOF + else throwError $ Default "I/O error reading from port" + Right inBytes -> do + if BS.null inBytes + then return $ EOF + else return $ ByteVector inBytes +readByteVector args = if length args == 2 + then throwError $ TypeMismatch "(k port)" $ List args + else throwError $ NumArgs (Just 2) args + -- |Write to the given port -- -- LispVal Arguments: @@ -361,6 +420,18 @@ then throwError $ TypeMismatch "(character port)" $ List other else throwError $ NumArgs (Just 2) other +writeByteVector :: [LispVal] -> IOThrowsError LispVal +writeByteVector [obj, Port port] = do + ByteVector bs <- recDerefPtrs obj -- Last opportunity to do this before writing + output <- liftIO $ try' (liftIO $ BS.hPut port bs) + case output of + Left _ -> throwError $ Default "I/O error writing to port" + Right _ -> return $ Nil "" +writeByteVector other = + if length other == 2 + then throwError $ TypeMismatch "(bytevector port)" $ List other + else throwError $ NumArgs (Just 2) other + -- |Determine if the given file exists -- -- Arguments: @@ -1239,7 +1310,7 @@ List l <- stringToList args return $ Vector $ listArray (0, length l - 1) l vectorToString :: [LispVal] -> IOThrowsError LispVal -vectorToString [p@(Pointer _ _)] = derefPtr p >>= box >>= listToString +vectorToString [p@(Pointer _ _)] = derefPtr p >>= box >>= vectorToString --vectorToString [(List [])] = return $ String "" --vectorToString [(List l)] = liftThrows $ buildString l vectorToString [(Vector v)] = do @@ -1542,11 +1613,21 @@ -- |Helper function to perform a binary logic operation on two LispVal arguments. boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal -boolBinop unpacker op args = if length args /= 2 +boolBinop unpacker op args = if length args < 2 then throwError $ NumArgs (Just 2) args - else do left <- unpacker $ args !! 0 - right <- unpacker $ args !! 1 - return $ Bool $ left `op` right + else do + result <- cmp op (head args) (tail args) + return $ Bool result + where + cmp op b1 (b2 : bs) = do + b1' <- unpacker b1 + b2' <- unpacker b2 + let result = op b1' b2' + if result + then cmp op b2 bs + else return False + cmp _ _ _ = return True + -- |Perform the given function against a single LispVal argument unaryOp :: (LispVal -> ThrowsError LispVal) -> [LispVal] -> ThrowsError LispVal diff --git a/husk-scheme.cabal b/husk-scheme.cabal --- a/husk-scheme.cabal +++ b/husk-scheme.cabal @@ -1,11 +1,11 @@ Name: husk-scheme -Version: 3.14 +Version: 3.15 Synopsis: R5RS Scheme interpreter, compiler, and library. Description: <> . - A dialect of R5RS Scheme written in Haskell. Advanced - features are provided including: + Husk is a dialect of Scheme written in Haskell that implements a superset of + the R5RS standard. Advanced features are provided including: . * First-class continuations of unlimited extent . @@ -13,6 +13,8 @@ . * Low-level explicit renaming macros . + * Library syntax from the R7RS standard + . * A foreign function interface (FFI) to Haskell . * Full numeric tower providing support for real, rational, and complex numbers @@ -26,6 +28,12 @@ Husk may be used as either a stand-alone interpreter or as an extension language within a larger Haskell application. By closely following the R5RS standard, the intent is to develop a Scheme that is as compatible as possible with other R5RS Schemes. Husk is mature enough for use in production, however it is not optimized for performance-critical applications. . Scheme is one of two main dialects of Lisp. Scheme follows a minimalist design philosophy: the core language consists of a small number of fundamental forms which may be used to implement other built-in forms. Scheme is an excellent language for writing small, elegant programs, and may also be used to write scripts or embed scripting functionality within a larger application. + . + For documentation and examples, see + . + . + For detailed information on each release, see + . License: MIT License-file: LICENSE @@ -42,7 +50,7 @@ ChangeLog.markdown LICENSE AUTHORS -Data-Files: lib/*.scm lib/husk/*.sld lib/husk/*.scm lib/scheme/*.sld lib/srfi/*.scm +Data-Files: lib/*.scm lib/husk/*.sld lib/husk/*.scm lib/scheme/*.sld lib/srfi/*.scm lib/srfi/*.sld Source-Repository head Type: git diff --git a/lib/core.scm b/lib/core.scm --- a/lib/core.scm +++ b/lib/core.scm @@ -14,10 +14,6 @@ (define (list . objs) objs) (define (id obj) obj) -; TODO: this is not flipping args. not part of R5RS, but -; as it is now, what is the point? -(define (flip func) (lambda (arg1 arg2) (func arg1 arg2))) - (define (curry func arg1) (lambda (arg) (apply func (cons arg1 (list arg))))) (define (compose f g) (lambda (arg) (f (apply g arg)))) @@ -35,6 +31,13 @@ (define (product . lst) (foldl * 1 lst)) (define (square z) (* z z)) +(define (exact-integer-sqrt x) + (let ((res (sqrt x))) + (if (exact? res) + (values res 0) + (let ((res (inexact->exact (truncate res)))) + (values res (- x (* res res))))))) + ; Forms from R5RS for and/or (define-syntax and (syntax-rules () @@ -68,7 +71,7 @@ (and (exact? num) (integer? num))) (define (length lst) (foldl (lambda (x y) (+ y 1)) 0 lst)) -(define (reverse lst) (foldl (flip cons) '() lst)) +(define (reverse lst) (foldl cons '() lst)) (define-syntax begin (syntax-rules () @@ -565,6 +568,7 @@ ;; END ;; More functions from r7rs +(define (features) *features*) (define-syntax def-copy-in-place (er-macro-transformer (lambda (expr rename compare) @@ -580,6 +584,23 @@ (def-copy-in-place vector) ;; END +;; Simplified versions of every/any from SRFI-1 +(define (any pred lst) + (let any* ((l (map pred lst))) + (cond + ((null? l) #f) ; Empty list + ((car l) #t) ; Done + (else + (any* (cdr l)))))) +(define (every pred lst) + (let every* ((l (map pred lst))) + (cond + ((null? l) #t) ; Empty list + ((car l) + (every* (cdr l))) + (else + #f)))) + ;; Macros from r7rs (define-syntax when (syntax-rules () @@ -602,6 +623,132 @@ (er-macro-transformer (lambda (expr rename compare) (apply error (cdr expr))))) + +(define-syntax + let-values + (syntax-rules + () + ((let-values (binding ...) body0 body1 ...) + (let-values + "bind" + (binding ...) + () + ((lambda () body0 body1 ...)))) + ;(begin body0 body1 ...))) + ((let-values "bind" () tmps body) + (let tmps body)) + ((let-values + "bind" + ((b0 e0) binding ...) + tmps + body) + (let-values + "mktmp" + b0 + e0 + () + (binding ...) + tmps + body)) + ((let-values + "mktmp" + () + e0 + args + bindings + tmps + body) + (call-with-values + (lambda () e0) + (lambda args + (let-values "bind" bindings tmps body)))) + ((let-values + "mktmp" + (a . b) + e0 + (arg ...) + bindings + (tmp ...) + body) + (let-values + "mktmp" + b + e0 + (arg ... x) + bindings + (tmp ... (a x)) + body)) + ((let-values + "mktmp" + a + e0 + (arg ...) + bindings + (tmp ...) + body) + (call-with-values + (lambda () e0) + ;(lambda (arg ... x) + (lambda (arg ... . x) + (let-values "bind" bindings (tmp ... (a x)) body)))))) + +(define-syntax let*-values + (syntax-rules () + ((let*-values () body0 body1 ...) + (let () body0 body1 ...)) + + ((let*-values (binding0 binding1 ...) + body0 body1 ...) + (let-values (binding0) + (let*-values (binding1 ...) + body0 body1 ...))))) + +;; TODO: +;; (define-syntax define-values +;; (syntax-rules () +;; ((define-values () expr) +;; (define dummy +;; (call-with-values (lambda () expr) +;; (lambda args #f)))) +;; +;; ((define-values (var) expr) +;; (define var expr)) +;; +;; ((define-values (var0 var1 ... varn) expr) +;; ;(begin +;; ((lambda () +;; (define var0 +;; (call-with-values (lambda () expr) +;; list)) +;; (define var1 +;; (let ((v (cadr var0))) +;; (set-cdr! var0 (cddr var0)) +;; v)) ... +;; (define varn +;; (let ((v (cadr var0))) +;; (set! var0 (car var0)) +;; v))))) +;; +;; ; ((define-values (var0 var1 ... . varn) expr) +;; ; ;(begin +;; ; ((lambda () +;; ; (define var0 +;; ; (call-with-values (lambda () expr) +;; ; list)) +;; ; (define var1 +;; ; (let ((v (cadr var0))) +;; ; (set-cdr! var0 (cddr var0)) +;; ; v)) ... +;; ; (define varn +;; ; (let ((v (cdr var0))) +;; ; (set! var0 (car var0)) +;; ; v))))) +;; +;; ((define-values var expr) +;; (define var +;; (call-with-values (lambda () expr) +;; list))))) + ;; ;; SRFI-0 (cond-expand) from r7rs ;; @@ -612,9 +759,8 @@ (define (check x) (if (pair? x) (case (car x) -; TODO: these fail because and/or not part of stdlib, but SRFI 1 -; TODO: ((and) (every check (cdr x))) -; TODO: ((or) (any check (cdr x))) + ((and) (every check (cdr x))) + ((or) (any check (cdr x))) ((not) (not (check (cadr x)))) ((library) (eval `(module-exists? ',(cadr x)) *meta-env*)) (else (error "cond-expand: bad feature" x))) diff --git a/lib/husk/pretty-print.sld b/lib/husk/pretty-print.sld --- a/lib/husk/pretty-print.sld +++ b/lib/husk/pretty-print.sld @@ -1,4 +1,5 @@ (define-library (husk pretty-print) (export pretty-print) - (import (scheme r5rs)) + (import (scheme base) + (scheme write)) (include "pp-sexp.scm")) diff --git a/lib/husk/random.sld b/lib/husk/random.sld --- a/lib/husk/random.sld +++ b/lib/husk/random.sld @@ -2,6 +2,6 @@ (export random randint) - (import (scheme r5rs)) + (import (scheme base)) (include "random.scm")) diff --git a/lib/scheme/base.sld b/lib/scheme/base.sld --- a/lib/scheme/base.sld +++ b/lib/scheme/base.sld @@ -160,11 +160,11 @@ zero? ;=> - ;binary-port? - ;boolean=? + binary-port? + boolean=? ;bytevector-u8-set! ;call-with-port - ;close-port + close-port cond-expand ;current-error-port ;define @@ -176,10 +176,10 @@ ;error-object-irritants ;error-object-message ;error-object? - ;exact-integer-sqrt + exact-integer-sqrt exact-integer? exact? - ;features + features ;file-error? ;floor-quotient ;floor-remainder @@ -190,11 +190,11 @@ ;guard ;if inexact? - ;input-port-open? + input-port-open? ;lambda - ;let*-values + let*-values ;let-syntax - ;let-values + let-values letrec* ;letrec-syntax list-copy @@ -205,7 +205,7 @@ ;open-input-string ;open-output-bytevector ;open-output-string - ;output-port-open? + output-port-open? ;parameterize ;peek-u8 ;port? @@ -224,30 +224,30 @@ square string->vector string-copy! - ;string-fill! + string-fill! string-for-each string-map ;string-set! ;symbol=? syntax-error ;syntax-rules - ;textual-port? + textual-port? ;truncate-quotient ;truncate-remainder ;truncate/ ;u8-ready? - ;unless + unless ;unquote ;unquote-splicing vector->string vector-append vector-copy vector-copy! - ;vector-fill! + vector-fill! vector-for-each vector-map ;vector-set! - ;when + when ;with-exception-handler ;write-bytevector ;write-string diff --git a/lib/scheme/case-lambda.sld b/lib/scheme/case-lambda.sld --- a/lib/scheme/case-lambda.sld +++ b/lib/scheme/case-lambda.sld @@ -25,19 +25,24 @@ ((cl (syntax-rules ::: () ((cl) (error "no matching clause")) - ((cl ((p :::) . body) . rest) + ((cl ((p :::) body :::) rest :::) + ;((cl ((p :::) . body) . rest) (if (= len (length '(p :::))) (apply (lambda (p :::) - . body) + body :::) + ;. body) args) - (cl . rest))) - ((cl ((p ::: . tail) . body) - . rest) - (if (>= len (length '(p :::))) - (apply - (lambda (p ::: . tail) - . body) - args) - (cl . rest)))))) + (cl rest :::))) + ;(cl . rest))) + ; TODO: for now, var-length arg support is broken + ;((cl ((p ::: . tail) . body) + ; . rest) + ; (if (>= len (length '(p :::))) + ; (apply + ; (lambda (p ::: . tail) + ; . body) + ; args) + ; (cl . rest))) + ))) (cl (params body0 ...) ...))))))) )) diff --git a/lib/scheme/char.sld b/lib/scheme/char.sld --- a/lib/scheme/char.sld +++ b/lib/scheme/char.sld @@ -15,11 +15,11 @@ char-ci=? char-ci>=? char-ci>? - ;char-downcase + char-downcase ;char-foldcase char-lower-case? char-numeric? - ;char-upcase + char-upcase char-upper-case? char-whitespace? digit-value diff --git a/lib/scheme/process-context.sld b/lib/scheme/process-context.sld --- a/lib/scheme/process-context.sld +++ b/lib/scheme/process-context.sld @@ -9,7 +9,9 @@ (define-library (scheme process-context) (export - + system + exit-success + exit-fail ; TODO: ; command-line ; emergency-exit diff --git a/lib/scheme/r5rs.sld b/lib/scheme/r5rs.sld --- a/lib/scheme/r5rs.sld +++ b/lib/scheme/r5rs.sld @@ -7,12 +7,223 @@ ;;; r7rs-small r5rs library ;;; - -; TODO: well obviously this won't work, since it includes itself -; need a way to load r5rsEnv on demand. unfortunately the direct bindings -; null-env, etc are supposed to be in r5rs. so may need a husk-specific -; function to do it... -; -;(define-library (scheme r5rs) -; (export-all) -; (import (scheme r5rs))) +(define-library (scheme r5rs) + (export + * + + + - + / + < + <= + = + > + >= + abs + acos + and + angle + append + apply + asin + assoc + assq + assv + atan + begin + boolean? + caaaar + caaadr + caaar + caadar + caaddr + caadr + caar + cadaar + cadadr + cadar + caddar + cadddr + caddr + cadr + call-with-current-continuation + call-with-input-file + call-with-output-file + call-with-values + car + case + cdaaar + cdaadr + cdaar + cdadar + cdaddr + cdadr + cdar + cddaar + cddadr + cddar + cdddar + cddddr + cdddr + cddr + cdr + ceiling + char->integer + char-alphabetic? + char-ci<=? + char-ci=? + char-ci>? + char-downcase + char-lower-case? + char-numeric? + char-ready? + char-upcase + char-upper-case? + char-whitespace? + char<=? + char=? + char>? + char? + close-input-port + close-output-port + complex? + cond + cons + cos + current-input-port + current-output-port + ;define + ;define-syntax + delay + denominator + display + do + dynamic-wind + eof-object? + eq? + equal? + eqv? + eval + even? + exact->inexact + exact? + exp + expt + floor + for-each + force + gcd + ;if + imag-part + inexact->exact + inexact? + input-port? + integer->char + integer? + interaction-environment + ;lambda + lcm + length + let + let* + ;let-syntax + letrec + ;letrec-syntax + list + list->string + list->vector + list-ref + list-tail + list? + load + log + magnitude + make-polar + make-rectangular + make-string + make-vector + map + max + member + memq + memv + min + modulo + negative? + newline + not + null-environment + null? + number->string + number? + numerator + odd? + open-input-file + open-output-file + or + output-port? + pair? + peek-char + positive? + procedure? + quasiquote + ;quote + quotient + rational? + rationalize + read + read-char + real-part + real? + remainder + reverse + round + ;scheme-report-environment + ;set! + ;set-car! + ;set-cdr! + sin + sqrt + string + string->list + string->number + string->symbol + string-append + string-ci<=? + string-ci=? + string-ci>? + string-copy + string-fill! + string-length + string-ref + ;string-set! + string<=? + string=? + string>? + string? + substring + symbol->string + symbol? + tan + truncate + values + vector + vector->list + vector-fill! + vector-length + vector-ref + ;vector-set! + vector? + ;optional in r5rs - with-input-from-file + ;optional in r5rs - with-output-to-file + write + write-char + zero?) + (import (scheme))) diff --git a/lib/scheme/time.sld b/lib/scheme/time.sld --- a/lib/scheme/time.sld +++ b/lib/scheme/time.sld @@ -13,9 +13,9 @@ current-jiffy jiffies-per-second) (import - (scheme r5rs) ; TODO: use proper r7rs library for inexact->exact!!!!! + (scheme base) (scheme time posix)) (begin (define (jiffies-per-second) 10000) (define (current-jiffy) - (inexact->exact (* (jiffies-per-second) (current-second)))))) + (exact (* (jiffies-per-second) (current-second)))))) diff --git a/lib/srfi/1.sld b/lib/srfi/1.sld new file mode 100644 --- /dev/null +++ b/lib/srfi/1.sld @@ -0,0 +1,5 @@ +(define-library (srfi 1) + (export-all) + (import (scheme base) + (scheme cxr)) + (include "srfi-1.scm")) diff --git a/lib/srfi/2.sld b/lib/srfi/2.sld new file mode 100644 --- /dev/null +++ b/lib/srfi/2.sld @@ -0,0 +1,5 @@ +(define-library (srfi 2) + (export + and-let*) + (include "srfi-2.scm")) + diff --git a/lib/srfi/69.sld b/lib/srfi/69.sld new file mode 100644 --- /dev/null +++ b/lib/srfi/69.sld @@ -0,0 +1,28 @@ +(define-library (srfi 69) + (export + make-hash-table + hash-table? + alist->hash-table + ;hash-table-equivalence-function + ;hash-table-hash-function + hash-table-ref + ;hash-table-ref/default + ;hash-table-set! + ;TODO: should implement this: hash-table-delete! + hash-table-exists? + hash-table-update! + ;hash-table-update!/default + hash-table-size + hash-table-keys + hash-table-values + hash-table-walk + hash-table-fold + hash-table->alist + hash-table-copy + hash-table-merge! + ;hash + ;string-hash + ;string-ci-hash + ;hash-by-identity + ) + (import (scheme)))